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