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      my %param = validate_with(params => \@_,
 969                                spec   => {bug => {type => SCALAR,
 970                                                   regex => qr/^\d+$/,
 971                                                  },
 972                                           status => {type => HASHREF,
 973                                                      optional => 1,
 974                                                     },
 975                                           days_until => {type => BOOLEAN,
 976                                                          default => 0,
 977                                                         },
 978                                           ignore_time => {type => BOOLEAN,
 979                                                           default => 0,
 980                                                          },
 981                                          },
 982                               );
 983      # This is what we return if the bug cannot be archived.
 984      my $cannot_archive = $param{days_until}?-1:0;
 985      # read the status information
 986      my $status = $param{status};
 987      if (not exists $param{status} or not defined $status) {
 988           $status = read_bug(bug=>$param{bug});
 989           if (not defined $status) {
 990                print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
 991                return undef;
 992           }
 993      }
 994      # Bugs can be archived if they are
 995      # 1. Closed
 996      if (not defined $status->{done} or not length $status->{done}) {
 997           print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
 998           return $cannot_archive
 999      }
1000      # Check to make sure that the bug has none of the unremovable tags set
1001      if (@{$config{removal_unremovable_tags}}) {
1002           for my $tag (split ' ', ($status->{keywords}||'')) {
1003                if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
1004                     print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
1005                     return $cannot_archive;
1006                }
1007           }
1008      }
1009
1010      # If we just are checking if the bug can be archived, we'll not even bother
1011      # checking the versioning information if the bug has been -done for less than 28 days.
1012      my $log_file = getbugcomponent($param{bug},'log');
1013      if (not defined $log_file or not -e $log_file) {
1014           print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
1015           return $cannot_archive;
1016      }
1017      my @log_files = $log_file, (map {my $log = getbugcomponent($_,'log');
1018                                            defined $log ? ($log) : ();
1019                                       }
1020                            split / /, $status->{mergedwith});
1021      my $max_log_age = max(map {-e $_?($config{remove_age} - -M _):0}
1022                            @log_files);
1023      if (not $param{days_until} and not $param{ignore_time}
1024          and $max_log_age > 0
1025         ) {
1026           print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
1027           return $cannot_archive;
1028      }
1029      # At this point, we have to get the versioning information for this bug.
1030      # We examine the set of distribution tags. If a bug has no distribution
1031      # tags set, we assume a default set, otherwise we use the tags the bug
1032      # has set.
1033
1034      # In cases where we are assuming a default set, if the severity
1035      # is strong, we use the strong severity default; otherwise, we
1036      # use the normal default.
1037
1038      # There must be fixed_versions for us to look at the versioning
1039      # information
1040      my $min_fixed_time = time;
1041      my $min_archive_days = 0;
1042      if (@{$status->{fixed_versions}}) {
1043           my %dist_tags;
1044           @dist_tags{@{$config{removal_distribution_tags}}} =
1045                (1) x @{$config{removal_distribution_tags}};
1046           my %dists;
1047           for my $tag (split ' ', ($status->{keywords}||'')) {
1048                next unless exists $config{distribution_aliases}{$tag};
1049                next unless $dist_tags{$config{distribution_aliases}{$tag}};
1050                $dists{$config{distribution_aliases}{$tag}} = 1;
1051           }
1052           if (not keys %dists) {
1053                if (isstrongseverity($status->{severity})) {
1054                     @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1055                          (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1056                }
1057                else {
1058                     @dists{@{$config{removal_default_distribution_tags}}} =
1059                          (1) x @{$config{removal_default_distribution_tags}};
1060                }
1061           }
1062           my %source_versions;
1063           my @sourceversions = get_versions(package => $status->{package},
1064                                             dist => [keys %dists],
1065                                             source => 1,
1066                                            );
1067           @source_versions{@sourceversions} = (1) x @sourceversions;
1068           # If the bug has not been fixed in the versions actually
1069           # distributed, then it cannot be archived.
1070           if ('found' eq max_buggy(bug => $param{bug},
1071                                    sourceversions => [keys %source_versions],
1072                                    found          => $status->{found_versions},
1073                                    fixed          => $status->{fixed_versions},
1074                                    version_cache  => $version_cache,
1075                                    package        => $status->{package},
1076                                   )) {
1077                print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1078                return $cannot_archive;
1079           }
1080           # Since the bug has at least been fixed in the architectures
1081           # that matters, we check to see how long it has been fixed.
1082
1083           # If $param{ignore_time}, then we should ignore time.
1084           if ($param{ignore_time}) {
1085                return $param{days_until}?0:1;
1086           }
1087
1088           # To do this, we order the times from most recent to oldest;
1089           # when we come to the first found version, we stop.
1090           # If we run out of versions, we only report the time of the
1091           # last one.
1092           my %time_versions = get_versions(package => $status->{package},
1093                                            dist    => [keys %dists],
1094                                            source  => 1,
1095                                            time    => 1,
1096                                           );
1097           for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1098                my $buggy = buggy(bug => $param{bug},
1099                                  version        => $version,
1100                                  found          => $status->{found_versions},
1101                                  fixed          => $status->{fixed_versions},
1102                                  version_cache  => $version_cache,
1103                                  package        => $status->{package},
1104                                 );
1105                last if $buggy eq 'found';
1106                $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1107           }
1108           $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1109                # if there are no versions in the archive at all, then
1110                # we can archive if enough days have passed
1111                if @sourceversions;
1112      }
1113      # If $param{ignore_time}, then we should ignore time.
1114      if ($param{ignore_time}) {
1115           return $param{days_until}?0:1;
1116      }
1117      # 6. at least 28 days have passed since the last action has occured or the bug was closed
1118      my $age = ceil($max_log_age);
1119      if ($age > 0 or $min_archive_days > 0) {
1120           print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1121           return $param{days_until}?max($age,$min_archive_days):0;
1122      }
1123      else {
1124           return $param{days_until}?0:1;
1125      }
1126 }
1127
1128
1129 =head2 get_bug_status
1130
1131      my $status = get_bug_status(bug => $nnn);
1132
1133      my $status = get_bug_status($bug_num)
1134
1135 =head3 Options
1136
1137 =over
1138
1139 =item bug -- scalar bug number
1140
1141 =item status -- optional hashref of bug status as returned by readbug
1142 (can be passed to avoid rereading the bug information)
1143
1144 =item bug_index -- optional tied index of bug status infomration;
1145 currently not correctly implemented.
1146
1147 =item version -- optional version(s) to check package status at
1148
1149 =item dist -- optional distribution(s) to check package status at
1150
1151 =item arch -- optional architecture(s) to check package status at
1152
1153 =item bugusertags -- optional hashref of bugusertags
1154
1155 =item sourceversion -- optional arrayref of source/version; overrides
1156 dist, arch, and version. [The entries in this array must be in the
1157 "source/version" format.] Eventually this can be used to for caching.
1158
1159 =item indicatesource -- if true, indicate which source packages this
1160 bug could belong to (or does belong to in the case of bugs assigned to
1161 a source package). Defaults to true.
1162
1163 =back
1164
1165 Note: Currently the version information is cached; this needs to be
1166 changed before using this function in long lived programs.
1167
1168 =head3 Returns
1169
1170 Currently returns a hashref of status with the following keys.
1171
1172 =over
1173
1174 =item id -- bug number
1175
1176 =item bug_num -- duplicate of id
1177
1178 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1179
1180 =item tags -- duplicate of keywords
1181
1182 =item package -- name of package that the bug is assigned to
1183
1184 =item severity -- severity of the bug
1185
1186 =item pending -- pending state of the bug; one of following possible
1187 values; values listed later have precedence if multiple conditions are
1188 satisifed:
1189
1190 =over
1191
1192 =item pending -- default state
1193
1194 =item forwarded -- bug has been forwarded
1195
1196 =item pending-fixed -- bug is tagged pending
1197
1198 =item fixed -- bug is tagged fixed
1199
1200 =item absent -- bug does not apply to this distribution/architecture
1201
1202 =item done -- bug is resolved in this distribution/architecture
1203
1204 =back
1205
1206 =item location -- db-h or archive; the location in the filesystem
1207
1208 =item subject -- title of the bug
1209
1210 =item last_modified -- epoch that the bug was last modified
1211
1212 =item date -- epoch that the bug was filed
1213
1214 =item originator -- bug reporter
1215
1216 =item log_modified -- epoch that the log file was last modified
1217
1218 =item msgid -- Message id of the original bug report
1219
1220 =back
1221
1222
1223 Other key/value pairs are returned but are not currently documented here.
1224
1225 =cut
1226
1227 sub get_bug_status {
1228      if (@_ == 1) {
1229           unshift @_, 'bug';
1230      }
1231      state $spec =
1232         {bug       => {type => SCALAR,
1233                        regex => qr/^\d+$/,
1234                       },
1235          status    => {type => HASHREF,
1236                        optional => 1,
1237                       },
1238          bug_index => {type => OBJECT,
1239                        optional => 1,
1240                       },
1241          version   => {type => SCALAR|ARRAYREF,
1242                        optional => 1,
1243                       },
1244          dist       => {type => SCALAR|ARRAYREF,
1245                         optional => 1,
1246                        },
1247          arch       => {type => SCALAR|ARRAYREF,
1248                         optional => 1,
1249                        },
1250          bugusertags   => {type => HASHREF,
1251                            optional => 1,
1252                           },
1253          sourceversions => {type => ARRAYREF,
1254                             optional => 1,
1255                            },
1256          indicatesource => {type => BOOLEAN,
1257                             default => 1,
1258                            },
1259          binary_to_source_cache => {type => HASHREF,
1260                                     optional => 1,
1261                                    },
1262          schema => {type => OBJECT,
1263                     optional => 1,
1264                    },
1265         };
1266      my %param = validate_with(params => \@_,
1267                                spec   => $spec,
1268                               );
1269      my %status;
1270
1271      if (defined $param{bug_index} and
1272          exists $param{bug_index}{$param{bug}}) {
1273          %status = %{ $param{bug_index}{$param{bug}} };
1274          $status{pending} = $status{ status };
1275          $status{id} = $param{bug};
1276          return \%status;
1277      }
1278      my $statuses = get_bug_statuses(@_);
1279      if (exists $statuses->{$param{bug}}) {
1280          return $statuses->{$param{bug}};
1281      } else {
1282         return {};
1283      }
1284 }
1285
1286 sub get_bug_statuses {
1287      state $spec =
1288         {bug       => {type => SCALAR|ARRAYREF,
1289                       },
1290          status    => {type => HASHREF,
1291                        optional => 1,
1292                       },
1293          bug_index => {type => OBJECT,
1294                        optional => 1,
1295                       },
1296          version   => {type => SCALAR|ARRAYREF,
1297                        optional => 1,
1298                       },
1299          dist       => {type => SCALAR|ARRAYREF,
1300                         optional => 1,
1301                        },
1302          arch       => {type => SCALAR|ARRAYREF,
1303                         optional => 1,
1304                        },
1305          bugusertags   => {type => HASHREF,
1306                            optional => 1,
1307                           },
1308          sourceversions => {type => ARRAYREF,
1309                             optional => 1,
1310                            },
1311          indicatesource => {type => BOOLEAN,
1312                             default => 1,
1313                            },
1314          binary_to_source_cache => {type => HASHREF,
1315                                     optional => 1,
1316                                    },
1317          schema => {type => OBJECT,
1318                     optional => 1,
1319                    },
1320         };
1321      my %param = validate_with(params => \@_,
1322                                spec   => $spec,
1323                               );
1324      my %status;
1325      my %statuses;
1326      if (defined $param{schema}) {
1327          my @bug_statuses =
1328              $param{schema}->resultset('BugStatus')->
1329              search_rs({id => [make_list($param{bug})]},
1330                        {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->
1331                            all();
1332          for my $bug_status (@bug_statuses) {
1333              $statuses{$bug_status->{bug_num}} =
1334                  $bug_status;
1335              for my $field (qw(blocks blockedby done),
1336                             qw(tags mergedwith)
1337                            ) {
1338                  $bug_status->{$field} //='';
1339              }
1340              $bug_status->{keywords} =
1341                  $bug_status->{tags};
1342              $bug_status->{location} = $bug_status->{archived}?'archive':'db-h';
1343              for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
1344                  $bug_status->{$field} = [split ' ', $bug_status->{$field} // ''];
1345              }
1346              for my $field (qw(found fixed)) {
1347                  # create the found/fixed hashes which indicate when a
1348                  # particular version was marked found or marked fixed.
1349                  @{$bug_status->{$field}}{@{$bug_status->{"${field}_versions"}}} =
1350                      (('') x (@{$bug_status->{"${field}_versions"}} -
1351                               @{$bug_status->{"${field}_date"}}),
1352                       @{$bug_status->{"${field}_date"}});
1353              }
1354              $bug_status->{id} = $bug_status->{bug_num};
1355          }
1356      } else {
1357          for my $bug (make_list($param{bug})) {
1358              if (defined $param{bug_index} and
1359                  exists $param{bug_index}{$bug}) {
1360                  my %status = %{$param{bug_index}{$bug}};
1361                  $status{pending} = $status{status};
1362                  $status{id} = $bug;
1363                  $statuses{$bug} = \%status;
1364              }
1365              elsif (defined $param{status} and
1366                     $param{status}{bug_num} == $bug
1367                    ) {
1368                  $statuses{$bug} = {%{$param{status}}};
1369              } else {
1370                  my $location = getbuglocation($bug, 'summary');
1371                  next if not defined $location or not length $location;
1372                  my %status = %{ readbug( $bug, $location ) };
1373                  $status{id} = $bug;
1374                  $statuses{$bug} = \%status;
1375              }
1376          }
1377      }
1378      for my $bug (keys %statuses) {
1379          my $status = $statuses{$bug};
1380
1381          if (defined $param{bugusertags}{$param{bug}}) {
1382              $status->{keywords} = "" unless defined $status->{keywords};
1383              $status->{keywords} .= " " unless $status->{keywords} eq "";
1384              $status->{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1385          }
1386          $status->{tags} = $status->{keywords};
1387          my %tags = map { $_ => 1 } split ' ', $status->{tags};
1388
1389          $status->{package} = '' if not defined $status->{package};
1390          $status->{"package"} =~ s/\s*$//;
1391
1392          $status->{source} = binary_to_source(binary=>[split /\s*,\s*/, $status->{package}],
1393                                               source_only => 1,
1394                                               exists $param{binary_to_source_cache}?
1395                                               (cache =>$param{binary_to_source_cache}):(),
1396                                              );
1397
1398          $status->{"package"} = 'unknown' if ($status->{"package"} eq '');
1399          $status->{"severity"} = 'normal' if (not defined $status->{severity} or $status->{"severity"} eq '');
1400
1401          $status->{"pending"} = 'pending';
1402          $status->{"pending"} = 'forwarded'         if (length($status->{"forwarded"}));
1403          $status->{"pending"} = 'pending-fixed'    if ($tags{pending});
1404          $status->{"pending"} = 'fixed'     if ($tags{fixed});
1405
1406
1407          my $presence = bug_presence(status => $status,
1408                                      bug => $bug,
1409                                      map{(exists $param{$_})?($_,$param{$_}):()}
1410                                      qw(sourceversions arch dist version found fixed package)
1411                                     );
1412          if (defined $presence) {
1413              if ($presence eq 'fixed') {
1414                  $status->{pending} = 'done';
1415              } elsif ($presence eq 'absent') {
1416                  $status->{pending} = 'absent';
1417              }
1418          }
1419      }
1420      return \%statuses;
1421 }
1422
1423 =head2 bug_presence
1424
1425      my $precence = bug_presence(bug => nnn,
1426                                  ...
1427                                 );
1428
1429 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1430 is found, absent, fixed, or no information is available in the
1431 distribution (dist) and/or architecture (arch) specified.
1432
1433
1434 =head3 Options
1435
1436 =over
1437
1438 =item bug -- scalar bug number
1439
1440 =item status -- optional hashref of bug status as returned by readbug
1441 (can be passed to avoid rereading the bug information)
1442
1443 =item bug_index -- optional tied index of bug status infomration;
1444 currently not correctly implemented.
1445
1446 =item version -- optional version to check package status at
1447
1448 =item dist -- optional distribution to check package status at
1449
1450 =item arch -- optional architecture to check package status at
1451
1452 =item sourceversion -- optional arrayref of source/version; overrides
1453 dist, arch, and version. [The entries in this array must be in the
1454 "source/version" format.] Eventually this can be used to for caching.
1455
1456 =back
1457
1458 =cut
1459
1460 sub bug_presence {
1461      my %param = validate_with(params => \@_,
1462                                spec   => {bug       => {type => SCALAR,
1463                                                         regex => qr/^\d+$/,
1464                                                        },
1465                                           status    => {type => HASHREF,
1466                                                         optional => 1,
1467                                                        },
1468                                           version   => {type => SCALAR|ARRAYREF,
1469                                                         optional => 1,
1470                                                        },
1471                                           dist       => {type => SCALAR|ARRAYREF,
1472                                                          optional => 1,
1473                                                         },
1474                                           arch       => {type => SCALAR|ARRAYREF,
1475                                                          optional => 1,
1476                                                         },
1477                                           sourceversions => {type => ARRAYREF,
1478                                                              optional => 1,
1479                                                             },
1480                                          },
1481                               );
1482      my %status;
1483      if (defined $param{status}) {
1484          %status = %{$param{status}};
1485      }
1486      else {
1487           my $location = getbuglocation($param{bug}, 'summary');
1488           return {} if not length $location;
1489           %status = %{ readbug( $param{bug}, $location ) };
1490      }
1491
1492      my @sourceversions;
1493      my $pseudo_desc = getpseudodesc();
1494      if (not exists $param{sourceversions}) {
1495           my %sourceversions;
1496           # pseudopackages do not have source versions by definition.
1497           if (exists $pseudo_desc->{$status{package}}) {
1498                # do nothing.
1499           }
1500           elsif (defined $param{version}) {
1501                foreach my $arch (make_list($param{arch})) {
1502                     for my $package (split /\s*,\s*/, $status{package}) {
1503                          my @temp = makesourceversions($package,
1504                                                        $arch,
1505                                                        make_list($param{version})
1506                                                       );
1507                          @sourceversions{@temp} = (1) x @temp;
1508                     }
1509                }
1510           } elsif (defined $param{dist}) {
1511                my %affects_distribution_tags;
1512                @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1513                     (1) x @{$config{affects_distribution_tags}};
1514                my $some_distributions_disallowed = 0;
1515                my %allowed_distributions;
1516                for my $tag (split ' ', ($status{keywords}||'')) {
1517                    if (exists $config{distribution_aliases}{$tag} and
1518                         exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1519                        $some_distributions_disallowed = 1;
1520                        $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1521                    }
1522                    elsif (exists $affects_distribution_tags{$tag}) {
1523                        $some_distributions_disallowed = 1;
1524                        $allowed_distributions{$tag} = 1;
1525                    }
1526                }
1527                my @archs = make_list(exists $param{arch}?$param{arch}:());
1528            GET_SOURCE_VERSIONS:
1529                foreach my $arch (@archs) {
1530                    for my $package (split /\s*,\s*/, $status{package}) {
1531                          my @versions = ();
1532                          my $source = 0;
1533                          if ($package =~ /^src:(.+)$/) {
1534                              $source = 1;
1535                              $package = $1;
1536                          }
1537                          foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1538                               # if some distributions are disallowed,
1539                               # and this isn't an allowed
1540                               # distribution, then we ignore this
1541                               # distribution for the purposees of
1542                               # finding versions
1543                               if ($some_distributions_disallowed and
1544                                   not exists $allowed_distributions{$dist}) {
1545                                    next;
1546                               }
1547                               push @versions, get_versions(package => $package,
1548                                                            dist    => $dist,
1549                                                            ($source?(arch => 'source'):
1550                                                             (defined $arch?(arch => $arch):())),
1551                                                           );
1552                          }
1553                          next unless @versions;
1554                          my @temp = make_source_versions(package => $package,
1555                                                          arch => $arch,
1556                                                          versions => \@versions,
1557                                                         );
1558                          @sourceversions{@temp} = (1) x @temp;
1559                     }
1560                }
1561                # this should really be split out into a subroutine,
1562                # but it'd touch so many things currently, that we fake
1563                # it; it's needed to properly handle bugs which are
1564                # erroneously assigned to the binary package, and we'll
1565                # probably have it go away eventually.
1566                if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1567                    @archs = (undef);
1568                    goto GET_SOURCE_VERSIONS;
1569                }
1570           }
1571
1572           # TODO: This should probably be handled further out for efficiency and
1573           # for more ease of distinguishing between pkg= and src= queries.
1574           # DLA: src= queries should just pass arch=source, and they'll be happy.
1575           @sourceversions = keys %sourceversions;
1576      }
1577      else {
1578           @sourceversions = @{$param{sourceversions}};
1579      }
1580      my $maxbuggy = 'undef';
1581      if (@sourceversions) {
1582           $maxbuggy = max_buggy(bug => $param{bug},
1583                                 sourceversions => \@sourceversions,
1584                                 found => $status{found_versions},
1585                                 fixed => $status{fixed_versions},
1586                                 package => $status{package},
1587                                 version_cache => $version_cache,
1588                                );
1589      }
1590      elsif (defined $param{dist} and
1591             not exists $pseudo_desc->{$status{package}}) {
1592           return 'absent';
1593      }
1594      if (length($status{done}) and
1595          (not @sourceversions or not @{$status{fixed_versions}})) {
1596           return 'fixed';
1597      }
1598      return $maxbuggy;
1599 }
1600
1601
1602 =head2 max_buggy
1603
1604      max_buggy()
1605
1606 =head3 Options
1607
1608 =over
1609
1610 =item bug -- scalar bug number
1611
1612 =item sourceversion -- optional arrayref of source/version; overrides
1613 dist, arch, and version. [The entries in this array must be in the
1614 "source/version" format.] Eventually this can be used to for caching.
1615
1616 =back
1617
1618 Note: Currently the version information is cached; this needs to be
1619 changed before using this function in long lived programs.
1620
1621
1622 =cut
1623 sub max_buggy{
1624      my %param = validate_with(params => \@_,
1625                                spec   => {bug       => {type => SCALAR,
1626                                                         regex => qr/^\d+$/,
1627                                                        },
1628                                           sourceversions => {type => ARRAYREF,
1629                                                              default => [],
1630                                                             },
1631                                           found          => {type => ARRAYREF,
1632                                                              default => [],
1633                                                             },
1634                                           fixed          => {type => ARRAYREF,
1635                                                              default => [],
1636                                                             },
1637                                           package        => {type => SCALAR,
1638                                                             },
1639                                           version_cache  => {type => HASHREF,
1640                                                              default => {},
1641                                                             },
1642                                          },
1643                               );
1644      # Resolve bugginess states (we might be looking at multiple
1645      # architectures, say). Found wins, then fixed, then absent.
1646      my $maxbuggy = 'absent';
1647      for my $package (split /\s*,\s*/, $param{package}) {
1648           for my $version (@{$param{sourceversions}}) {
1649                my $buggy = buggy(bug => $param{bug},
1650                                  version => $version,
1651                                  found => $param{found},
1652                                  fixed => $param{fixed},
1653                                  version_cache => $param{version_cache},
1654                                  package => $package,
1655                                 );
1656                if ($buggy eq 'found') {
1657                     return 'found';
1658                } elsif ($buggy eq 'fixed') {
1659                     $maxbuggy = 'fixed';
1660                }
1661           }
1662      }
1663      return $maxbuggy;
1664 }
1665
1666
1667 =head2 buggy
1668
1669      buggy(bug => nnn,
1670            found => \@found,
1671            fixed => \@fixed,
1672            package => 'foo',
1673            version => '1.0',
1674           );
1675
1676 Returns the output of Debbugs::Versions::buggy for a particular
1677 package, version and found/fixed set. Automatically turns found, fixed
1678 and version into source/version strings.
1679
1680 Caching can be had by using the version_cache, but no attempt to check
1681 to see if the on disk information is more recent than the cache is
1682 made. [This will need to be fixed for long-lived processes.]
1683
1684 =cut
1685
1686 sub buggy {
1687      my %param = validate_with(params => \@_,
1688                                spec   => {bug => {type => SCALAR,
1689                                                   regex => qr/^\d+$/,
1690                                                  },
1691                                           found => {type => ARRAYREF,
1692                                                     default => [],
1693                                                    },
1694                                           fixed => {type => ARRAYREF,
1695                                                     default => [],
1696                                                    },
1697                                           version_cache => {type => HASHREF,
1698                                                             optional => 1,
1699                                                            },
1700                                           package => {type => SCALAR,
1701                                                      },
1702                                           version => {type => SCALAR,
1703                                                      },
1704                                          },
1705                               );
1706      my @found = @{$param{found}};
1707      my @fixed = @{$param{fixed}};
1708      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1709           # We have non-source version versions
1710           @found = makesourceversions($param{package},undef,
1711                                       @found
1712                                      );
1713           @fixed = makesourceversions($param{package},undef,
1714                                       @fixed
1715                                      );
1716      }
1717      if ($param{version} !~ m{/}) {
1718           my ($version) = makesourceversions($param{package},undef,
1719                                              $param{version}
1720                                             );
1721           $param{version} = $version if defined $version;
1722      }
1723      # Figure out which source packages we need
1724      my %sources;
1725      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1726      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1727      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1728           $param{version} =~ m{/};
1729      my $version;
1730      if (not defined $param{version_cache} or
1731          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1732           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1733           foreach my $source (keys %sources) {
1734                my $srchash = substr $source, 0, 1;
1735                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1736                if (not defined $version_fh) {
1737                     # We only want to warn if it's a package which actually has a maintainer
1738                     my $maints = getmaintainers();
1739                     next if not exists $maints->{$source};
1740                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1741                     next;
1742                }
1743                $version->load($version_fh);
1744           }
1745           if (defined $param{version_cache}) {
1746                $param{version_cache}{join(',',sort keys %sources)} = $version;
1747           }
1748      }
1749      else {
1750           $version = $param{version_cache}{join(',',sort keys %sources)};
1751      }
1752      return $version->buggy($param{version},\@found,\@fixed);
1753 }
1754
1755 sub isstrongseverity {
1756     my $severity = shift;
1757     $severity = $config{default_severity} if
1758          not defined $severity or $severity eq '';
1759     return grep { $_ eq $severity } @{$config{strong_severities}};
1760 }
1761
1762 =head1 indexdb
1763
1764 =head2 generate_index_db_line
1765
1766         my $data = read_bug(bug => $bug,
1767                             location => $initialdir);
1768         # generate_index_db_line hasn't been written yet at all.
1769         my $line = generate_index_db_line($data);
1770
1771 Returns a line for a bug suitable to be written out to index.db.
1772
1773 =cut
1774
1775 sub generate_index_db_line {
1776     my ($data,$bug) = @_;
1777
1778     # just in case someone has given us a split out data
1779     $data = join_status_fields($data);
1780
1781     my $whendone = "open";
1782     my $severity = $config{default_severity};
1783     (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1784     $pkglist =~ s/^,+//;
1785     $pkglist =~ s/,+$//;
1786     $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1787     $whendone = "done" if defined $data->{done} and length $data->{done};
1788     $severity = $data->{severity} if length $data->{severity};
1789     return sprintf "%s %d %d %s [%s] %s %s\n",
1790         $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1791             $data->{originator}, $severity, $data->{keywords};
1792 }
1793
1794
1795
1796 =head1 PRIVATE FUNCTIONS
1797
1798 =cut
1799
1800 sub update_realtime {
1801         my ($file, %bugs) = @_;
1802
1803         # update realtime index.db
1804
1805         return () unless keys %bugs;
1806         my $idx_old = IO::File->new($file,'r')
1807              or die "Couldn't open ${file}: $!";
1808         my $idx_new = IO::File->new($file.'.new','w')
1809              or die "Couldn't open ${file}.new: $!";
1810
1811         binmode($idx_old,':raw:utf8');
1812         binmode($idx_new,':raw:encoding(UTF-8)');
1813         my $min_bug = min(keys %bugs);
1814         my $line;
1815         my @line;
1816         my %changed_bugs;
1817         while($line = <$idx_old>) {
1818              @line = split /\s/, $line;
1819              # Two cases; replacing existing line or adding new line
1820              if (exists $bugs{$line[1]}) {
1821                   my $new = $bugs{$line[1]};
1822                   delete $bugs{$line[1]};
1823                   $min_bug = min(keys %bugs);
1824                   if ($new eq "NOCHANGE") {
1825                        print {$idx_new} $line;
1826                        $changed_bugs{$line[1]} = $line;
1827                   } elsif ($new eq "REMOVE") {
1828                        $changed_bugs{$line[1]} = $line;
1829                   } else {
1830                        print {$idx_new} $new;
1831                        $changed_bugs{$line[1]} = $line;
1832                   }
1833              }
1834              else {
1835                   while ($line[1] > $min_bug) {
1836                        print {$idx_new} $bugs{$min_bug};
1837                        delete $bugs{$min_bug};
1838                        last unless keys %bugs;
1839                        $min_bug = min(keys %bugs);
1840                   }
1841                   print {$idx_new} $line;
1842              }
1843              last unless keys %bugs;
1844         }
1845         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1846
1847         print {$idx_new} <$idx_old>;
1848
1849         close($idx_new);
1850         close($idx_old);
1851
1852         rename("$file.new", $file);
1853
1854         return %changed_bugs;
1855 }
1856
1857 sub bughook_archive {
1858         my @refs = @_;
1859         filelock("$config{spool_dir}/debbugs.trace.lock");
1860         appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1861         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1862                                    map{($_,'REMOVE')} @refs);
1863         update_realtime("$config{spool_dir}/index.archive.realtime",
1864                         %bugs);
1865         unfilelock();
1866 }
1867
1868 sub bughook {
1869         my ( $type, %bugs_temp ) = @_;
1870         filelock("$config{spool_dir}/debbugs.trace.lock");
1871
1872         my %bugs;
1873         for my $bug (keys %bugs_temp) {
1874              my $data = $bugs_temp{$bug};
1875              appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1876
1877              $bugs{$bug} = generate_index_db_line($data,$bug);
1878         }
1879         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1880
1881         unfilelock();
1882 }
1883
1884
1885 1;
1886
1887 __END__