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