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