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