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