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     unfilelock();
 551     my $nn_hash = get_hashname($nn);
 552     use IO::File;
 553     my $t_fh = IO::File->new("/home/don/temp.txt",'a') or die "Unable to open ~don/temp.txt for writing: $!";
 554     use Data::Dumper;
 555     print {$t_fh} Dumper({%param,nn => $nn, nn_hash => $nn_hash, nextnumber => qx(cat nextnumber)});
 556     close $t_fh;
 557     if ($param{copy}) {
 558         my $c_hash = get_hashname($param{copy});
 559         for my $file (qw(log status summary report)) {
 560             copy("db-h/$c_hash/$param{copy}.$file",
 561                  "db-h/$nn_hash/${nn}.$file")
 562         }
 563     }
 564     else {
 565         for my $file (qw(log status summary report)) {
 566             overwritefile("db-h/$nn_hash/${nn}.$file",
 567                            "");
 568         }
 569     }
 570
 571     # this probably needs to be munged to do something more elegant
 572 #    &bughook('new', $clone, $data);
 573
 574     return($nn);
 575 }
 576
 577
 578
 579 my @v1fieldorder = qw(originator date subject msgid package
 580                       keywords done forwarded mergedwith severity);
 581
 582 =head2 makestatus
 583
 584      my $content = makestatus($status,$version)
 585      my $content = makestatus($status);
 586
 587 Creates the content for a status file based on the $status hashref
 588 passed.
 589
 590 Really only useful for writebug
 591
 592 Currently defaults to version 2 (non-encoded rfc1522 names) but will
 593 eventually default to version 3. If you care, you should specify a
 594 version.
 595
 596 =cut
 597
 598 sub makestatus {
 599     my ($data,$version) = @_;
 600     $version = 2 unless defined $version;
 601
 602     my $contents = '';
 603
 604     my %newdata = %$data;
 605     for my $field (qw(found fixed)) {
 606          if (exists $newdata{$field}) {
 607               $newdata{"${field}_date"} =
 608                    [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
 609          }
 610     }
 611     %newdata = %{join_status_fields(\%newdata)};
 612
 613     if ($version < 3) {
 614         for my $field (@rfc1522_fields) {
 615             $newdata{$field} = encode_rfc1522($newdata{$field});
 616         }
 617     }
 618
 619     # this is a bit of a hack; we should never, ever have \r or \n in
 620     # the fields of status. Kill them off here. [Eventually, this
 621     # should be superfluous.]
 622     for my $field (keys %newdata) {
 623         $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
 624     }
 625
 626     if ($version == 1) {
 627         for my $field (@v1fieldorder) {
 628             if (exists $newdata{$field} and defined $newdata{$field}) {
 629                 $contents .= "$newdata{$field}\n";
 630             } else {
 631                 $contents .= "\n";
 632             }
 633         }
 634     } elsif ($version == 2 or $version == 3) {
 635         # Version 2 or 3. Add a file format version number for the sake of
 636         # further extensibility in the future.
 637         $contents .= "Format-Version: $version\n";
 638         for my $field (keys %fields) {
 639             if (exists $newdata{$field} and defined $newdata{$field}
 640                 and $newdata{$field} ne '') {
 641                 # Output field names in proper case, e.g. 'Merged-With'.
 642                 my $properfield = $fields{$field};
 643                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 644                 $contents .= "$properfield: $newdata{$field}\n";
 645             }
 646         }
 647     }
 648
 649     return $contents;
 650 }
 651
 652 =head2 writebug
 653
 654      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 655
 656 Writes the bug status and summary files out.
 657
 658 Skips writting out a status file if minversion is 2
 659
 660 Does not call bughook if disablebughook is true.
 661
 662 =cut
 663
 664 sub writebug {
 665     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 666     my $change;
 667
 668     my %outputs = (1 => 'status', 2 => 'summary');
 669     for my $version (keys %outputs) {
 670         next if defined $minversion and $version < $minversion;
 671         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 672         die "can't find location for $ref" unless defined $status;
 673         open(S,"> $status.new") || die "opening $status.new: $!";
 674         print(S makestatus($data, $version)) ||
 675             die "writing $status.new: $!";
 676         close(S) || die "closing $status.new: $!";
 677         if (-e $status) {
 678             $change = 'change';
 679         } else {
 680             $change = 'new';
 681         }
 682         rename("$status.new",$status) || die "installing new $status: $!";
 683     }
 684
 685     # $disablebughook is a bit of a hack to let format migration scripts use
 686     # this function rather than having to duplicate it themselves.
 687     &bughook($change,$ref,$data) unless $disablebughook;
 688 }
 689
 690 =head2 unlockwritebug
 691
 692      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 693
 694 Writes a bug, then calls unfilelock; see writebug for what these
 695 options mean.
 696
 697 =cut
 698
 699 sub unlockwritebug {
 700     writebug(@_);
 701     unfilelock();
 702 }
 703
 704 =head1 VERSIONS
 705
 706 The following functions are exported with the :versions tag
 707
 708 =head2 addfoundversions
 709
 710      addfoundversions($status,$package,$version,$isbinary);
 711
 712 All use of this should be phased out in favor of Debbugs::Control::fixed/found
 713
 714 =cut
 715
 716
 717 sub addfoundversions {
 718     my $data = shift;
 719     my $package = shift;
 720     my $version = shift;
 721     my $isbinary = shift;
 722     return unless defined $version;
 723     undef $package if $package =~ m[(?:\s|/)];
 724     my $source = $package;
 725     if ($package =~ s/^src://) {
 726         $isbinary = 0;
 727         $source = $package;
 728     }
 729
 730     if (defined $package and $isbinary) {
 731         my @srcinfo = binary_to_source(binary => $package,
 732                                        version => $version);
 733         if (@srcinfo) {
 734             # We know the source package(s). Use a fully-qualified version.
 735             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 736             return;
 737         }
 738         # Otherwise, an unqualified version will have to do.
 739         undef $source;
 740     }
 741
 742     # Strip off various kinds of brain-damage.
 743     $version =~ s/;.*//;
 744     $version =~ s/ *\(.*\)//;
 745     $version =~ s/ +[A-Za-z].*//;
 746
 747     foreach my $ver (split /[,\s]+/, $version) {
 748         my $sver = defined($source) ? "$source/$ver" : '';
 749         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 750             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 751         }
 752         @{$data->{fixed_versions}} =
 753             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 754     }
 755 }
 756
 757 =head2 removefoundversions
 758
 759      removefoundversions($data,$package,$versiontoremove)
 760
 761 Removes found versions from $data
 762
 763 If a version is fully qualified (contains /) only versions matching
 764 exactly are removed. Otherwise, all versions matching the version
 765 number are removed.
 766
 767 Currently $package and $isbinary are entirely ignored, but accepted
 768 for backwards compatibilty.
 769
 770 =cut
 771
 772 sub removefoundversions {
 773     my $data = shift;
 774     my $package = shift;
 775     my $version = shift;
 776     my $isbinary = shift;
 777     return unless defined $version;
 778
 779     foreach my $ver (split /[,\s]+/, $version) {
 780          if ($ver =~ m{/}) {
 781               # fully qualified version
 782               @{$data->{found_versions}} =
 783                    grep {$_ ne $ver}
 784                         @{$data->{found_versions}};
 785          }
 786          else {
 787               # non qualified version; delete all matchers
 788               @{$data->{found_versions}} =
 789                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 790                         @{$data->{found_versions}};
 791          }
 792     }
 793 }
 794
 795
 796 sub addfixedversions {
 797     my $data = shift;
 798     my $package = shift;
 799     my $version = shift;
 800     my $isbinary = shift;
 801     return unless defined $version;
 802     undef $package if defined $package and $package =~ m[(?:\s|/)];
 803     my $source = $package;
 804
 805     if (defined $package and $isbinary) {
 806         my @srcinfo = binary_to_source(binary => $package,
 807                                        version => $version);
 808         if (@srcinfo) {
 809             # We know the source package(s). Use a fully-qualified version.
 810             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 811             return;
 812         }
 813         # Otherwise, an unqualified version will have to do.
 814         undef $source;
 815     }
 816
 817     # Strip off various kinds of brain-damage.
 818     $version =~ s/;.*//;
 819     $version =~ s/ *\(.*\)//;
 820     $version =~ s/ +[A-Za-z].*//;
 821
 822     foreach my $ver (split /[,\s]+/, $version) {
 823         my $sver = defined($source) ? "$source/$ver" : '';
 824         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 825             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 826         }
 827         @{$data->{found_versions}} =
 828             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 829     }
 830 }
 831
 832 sub removefixedversions {
 833     my $data = shift;
 834     my $package = shift;
 835     my $version = shift;
 836     my $isbinary = shift;
 837     return unless defined $version;
 838
 839     foreach my $ver (split /[,\s]+/, $version) {
 840          if ($ver =~ m{/}) {
 841               # fully qualified version
 842               @{$data->{fixed_versions}} =
 843                    grep {$_ ne $ver}
 844                         @{$data->{fixed_versions}};
 845          }
 846          else {
 847               # non qualified version; delete all matchers
 848               @{$data->{fixed_versions}} =
 849                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 850                         @{$data->{fixed_versions}};
 851          }
 852     }
 853 }
 854
 855
 856
 857 =head2 splitpackages
 858
 859      splitpackages($pkgs)
 860
 861 Split a package string from the status file into a list of package names.
 862
 863 =cut
 864
 865 sub splitpackages {
 866     my $pkgs = shift;
 867     return unless defined $pkgs;
 868     return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
 869 }
 870
 871
 872 =head2 bug_archiveable
 873
 874      bug_archiveable(bug => $bug_num);
 875
 876 Options
 877
 878 =over
 879
 880 =item bug -- bug number (required)
 881
 882 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
 883
 884 =item version -- Debbugs::Version information (optional)
 885
 886 =item days_until -- return days until the bug can be archived
 887
 888 =back
 889
 890 Returns 1 if the bug can be archived
 891 Returns 0 if the bug cannot be archived
 892
 893 If days_until is true, returns the number of days until the bug can be
 894 archived, -1 if it cannot be archived. 0 means that the bug can be
 895 archived the next time the archiver runs.
 896
 897 Returns undef on failure.
 898
 899 =cut
 900
 901 # This will eventually need to be fixed before we start using mod_perl
 902 our $version_cache = {};
 903 sub bug_archiveable{
 904      my %param = validate_with(params => \@_,
 905                                spec   => {bug => {type => SCALAR,
 906                                                   regex => qr/^\d+$/,
 907                                                  },
 908                                           status => {type => HASHREF,
 909                                                      optional => 1,
 910                                                     },
 911                                           days_until => {type => BOOLEAN,
 912                                                          default => 0,
 913                                                         },
 914                                           ignore_time => {type => BOOLEAN,
 915                                                           default => 0,
 916                                                          },
 917                                          },
 918                               );
 919      # This is what we return if the bug cannot be archived.
 920      my $cannot_archive = $param{days_until}?-1:0;
 921      # read the status information
 922      my $status = $param{status};
 923      if (not exists $param{status} or not defined $status) {
 924           $status = read_bug(bug=>$param{bug});
 925           if (not defined $status) {
 926                print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
 927                return undef;
 928           }
 929      }
 930      # Bugs can be archived if they are
 931      # 1. Closed
 932      if (not defined $status->{done} or not length $status->{done}) {
 933           print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
 934           return $cannot_archive
 935      }
 936      # Check to make sure that the bug has none of the unremovable tags set
 937      if (@{$config{removal_unremovable_tags}}) {
 938           for my $tag (split ' ', ($status->{keywords}||'')) {
 939                if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
 940                     print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
 941                     return $cannot_archive;
 942                }
 943           }
 944      }
 945
 946      # If we just are checking if the bug can be archived, we'll not even bother
 947      # checking the versioning information if the bug has been -done for less than 28 days.
 948      my $log_file = getbugcomponent($param{bug},'log');
 949      if (not defined $log_file) {
 950           print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
 951           return $cannot_archive;
 952      }
 953      my $max_log_age = max(map {$config{remove_age} - -M $_}
 954                            $log_file, map {my $log = getbugcomponent($_,'log');
 955                                            defined $log ? ($log) : ();
 956                                       }
 957                            split / /, $status->{mergedwith}
 958                        );
 959      if (not $param{days_until} and not $param{ignore_time}
 960          and $max_log_age > 0
 961         ) {
 962           print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
 963           return $cannot_archive;
 964      }
 965      # At this point, we have to get the versioning information for this bug.
 966      # We examine the set of distribution tags. If a bug has no distribution
 967      # tags set, we assume a default set, otherwise we use the tags the bug
 968      # has set.
 969
 970      # In cases where we are assuming a default set, if the severity
 971      # is strong, we use the strong severity default; otherwise, we
 972      # use the normal default.
 973
 974      # There must be fixed_versions for us to look at the versioning
 975      # information
 976      my $min_fixed_time = time;
 977      my $min_archive_days = 0;
 978      if (@{$status->{fixed_versions}}) {
 979           my %dist_tags;
 980           @dist_tags{@{$config{removal_distribution_tags}}} =
 981                (1) x @{$config{removal_distribution_tags}};
 982           my %dists;
 983           for my $tag (split ' ', ($status->{keywords}||'')) {
 984                next unless exists $config{distribution_aliases}{$tag};
 985                next unless $dist_tags{$config{distribution_aliases}{$tag}};
 986                $dists{$config{distribution_aliases}{$tag}} = 1;
 987           }
 988           if (not keys %dists) {
 989                if (isstrongseverity($status->{severity})) {
 990                     @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
 991                          (1) x @{$config{removal_strong_severity_default_distribution_tags}};
 992                }
 993                else {
 994                     @dists{@{$config{removal_default_distribution_tags}}} =
 995                          (1) x @{$config{removal_default_distribution_tags}};
 996                }
 997           }
 998           my %source_versions;
 999           my @sourceversions = get_versions(package => $status->{package},
1000                                             dist => [keys %dists],
1001                                             source => 1,
1002                                            );
1003           @source_versions{@sourceversions} = (1) x @sourceversions;
1004           # If the bug has not been fixed in the versions actually
1005           # distributed, then it cannot be archived.
1006           if ('found' eq max_buggy(bug => $param{bug},
1007                                    sourceversions => [keys %source_versions],
1008                                    found          => $status->{found_versions},
1009                                    fixed          => $status->{fixed_versions},
1010                                    version_cache  => $version_cache,
1011                                    package        => $status->{package},
1012                                   )) {
1013                print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1014                return $cannot_archive;
1015           }
1016           # Since the bug has at least been fixed in the architectures
1017           # that matters, we check to see how long it has been fixed.
1018
1019           # If $param{ignore_time}, then we should ignore time.
1020           if ($param{ignore_time}) {
1021                return $param{days_until}?0:1;
1022           }
1023
1024           # To do this, we order the times from most recent to oldest;
1025           # when we come to the first found version, we stop.
1026           # If we run out of versions, we only report the time of the
1027           # last one.
1028           my %time_versions = get_versions(package => $status->{package},
1029                                            dist    => [keys %dists],
1030                                            source  => 1,
1031                                            time    => 1,
1032                                           );
1033           for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1034                my $buggy = buggy(bug => $param{bug},
1035                                  version        => $version,
1036                                  found          => $status->{found_versions},
1037                                  fixed          => $status->{fixed_versions},
1038                                  version_cache  => $version_cache,
1039                                  package        => $status->{package},
1040                                 );
1041                last if $buggy eq 'found';
1042                $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1043           }
1044           $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1045                # if there are no versions in the archive at all, then
1046                # we can archive if enough days have passed
1047                if @sourceversions;
1048      }
1049      # If $param{ignore_time}, then we should ignore time.
1050      if ($param{ignore_time}) {
1051           return $param{days_until}?0:1;
1052      }
1053      # 6. at least 28 days have passed since the last action has occured or the bug was closed
1054      my $age = ceil($max_log_age);
1055      if ($age > 0 or $min_archive_days > 0) {
1056           print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1057           return $param{days_until}?max($age,$min_archive_days):0;
1058      }
1059      else {
1060           return $param{days_until}?0:1;
1061      }
1062 }
1063
1064
1065 =head2 get_bug_status
1066
1067      my $status = get_bug_status(bug => $nnn);
1068
1069      my $status = get_bug_status($bug_num)
1070
1071 =head3 Options
1072
1073 =over
1074
1075 =item bug -- scalar bug number
1076
1077 =item status -- optional hashref of bug status as returned by readbug
1078 (can be passed to avoid rereading the bug information)
1079
1080 =item bug_index -- optional tied index of bug status infomration;
1081 currently not correctly implemented.
1082
1083 =item version -- optional version(s) to check package status at
1084
1085 =item dist -- optional distribution(s) to check package status at
1086
1087 =item arch -- optional architecture(s) to check package status at
1088
1089 =item bugusertags -- optional hashref of bugusertags
1090
1091 =item sourceversion -- optional arrayref of source/version; overrides
1092 dist, arch, and version. [The entries in this array must be in the
1093 "source/version" format.] Eventually this can be used to for caching.
1094
1095 =item indicatesource -- if true, indicate which source packages this
1096 bug could belong to (or does belong to in the case of bugs assigned to
1097 a source package). Defaults to true.
1098
1099 =back
1100
1101 Note: Currently the version information is cached; this needs to be
1102 changed before using this function in long lived programs.
1103
1104 =cut
1105
1106 sub get_bug_status {
1107      if (@_ == 1) {
1108           unshift @_, 'bug';
1109      }
1110      my %param = validate_with(params => \@_,
1111                                spec   => {bug       => {type => SCALAR,
1112                                                         regex => qr/^\d+$/,
1113                                                        },
1114                                           status    => {type => HASHREF,
1115                                                         optional => 1,
1116                                                        },
1117                                           bug_index => {type => OBJECT,
1118                                                         optional => 1,
1119                                                        },
1120                                           version   => {type => SCALAR|ARRAYREF,
1121                                                         optional => 1,
1122                                                        },
1123                                           dist       => {type => SCALAR|ARRAYREF,
1124                                                          optional => 1,
1125                                                         },
1126                                           arch       => {type => SCALAR|ARRAYREF,
1127                                                          optional => 1,
1128                                                         },
1129                                           bugusertags   => {type => HASHREF,
1130                                                             optional => 1,
1131                                                            },
1132                                           sourceversions => {type => ARRAYREF,
1133                                                              optional => 1,
1134                                                             },
1135                                           indicatesource => {type => BOOLEAN,
1136                                                              default => 1,
1137                                                             },
1138                                          },
1139                               );
1140      my %status;
1141
1142      if (defined $param{bug_index} and
1143          exists $param{bug_index}{$param{bug}}) {
1144           %status = %{ $param{bug_index}{$param{bug}} };
1145           $status{pending} = $status{ status };
1146           $status{id} = $param{bug};
1147           return \%status;
1148      }
1149      if (defined $param{status}) {
1150           %status = %{$param{status}};
1151      }
1152      else {
1153           my $location = getbuglocation($param{bug}, 'summary');
1154           return {} if not defined $location or not length $location;
1155           %status = %{ readbug( $param{bug}, $location ) };
1156      }
1157      $status{id} = $param{bug};
1158
1159      if (defined $param{bugusertags}{$param{bug}}) {
1160           $status{keywords} = "" unless defined $status{keywords};
1161           $status{keywords} .= " " unless $status{keywords} eq "";
1162           $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1163      }
1164      $status{tags} = $status{keywords};
1165      my %tags = map { $_ => 1 } split ' ', $status{tags};
1166
1167      $status{package} = '' if not defined $status{package};
1168      $status{"package"} =~ s/\s*$//;
1169
1170      $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1171                                         source_only => 1,
1172                                        );
1173
1174      $status{"package"} = 'unknown' if ($status{"package"} eq '');
1175      $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1176
1177      $status{"pending"} = 'pending';
1178      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
1179      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
1180      $status{"pending"} = 'fixed'           if ($tags{fixed});
1181
1182
1183      my $presence = bug_presence(status => \%status,
1184                                  map{(exists $param{$_})?($_,$param{$_}):()}
1185                                  qw(bug sourceversions arch dist version found fixed package)
1186                                 );
1187      if (defined $presence) {
1188           if ($presence eq 'fixed') {
1189                $status{pending} = 'done';
1190           }
1191           elsif ($presence eq 'absent') {
1192                $status{pending} = 'absent';
1193           }
1194      }
1195      return \%status;
1196 }
1197
1198 =head2 bug_presence
1199
1200      my $precence = bug_presence(bug => nnn,
1201                                  ...
1202                                 );
1203
1204 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1205 is found, absent, fixed, or no information is available in the
1206 distribution (dist) and/or architecture (arch) specified.
1207
1208
1209 =head3 Options
1210
1211 =over
1212
1213 =item bug -- scalar bug number
1214
1215 =item status -- optional hashref of bug status as returned by readbug
1216 (can be passed to avoid rereading the bug information)
1217
1218 =item bug_index -- optional tied index of bug status infomration;
1219 currently not correctly implemented.
1220
1221 =item version -- optional version to check package status at
1222
1223 =item dist -- optional distribution to check package status at
1224
1225 =item arch -- optional architecture to check package status at
1226
1227 =item sourceversion -- optional arrayref of source/version; overrides
1228 dist, arch, and version. [The entries in this array must be in the
1229 "source/version" format.] Eventually this can be used to for caching.
1230
1231 =back
1232
1233 =cut
1234
1235 sub bug_presence {
1236      my %param = validate_with(params => \@_,
1237                                spec   => {bug       => {type => SCALAR,
1238                                                         regex => qr/^\d+$/,
1239                                                        },
1240                                           status    => {type => HASHREF,
1241                                                         optional => 1,
1242                                                        },
1243                                           version   => {type => SCALAR|ARRAYREF,
1244                                                         optional => 1,
1245                                                        },
1246                                           dist       => {type => SCALAR|ARRAYREF,
1247                                                          optional => 1,
1248                                                         },
1249                                           arch       => {type => SCALAR|ARRAYREF,
1250                                                          optional => 1,
1251                                                         },
1252                                           sourceversions => {type => ARRAYREF,
1253                                                              optional => 1,
1254                                                             },
1255                                          },
1256                               );
1257      my %status;
1258      if (defined $param{status}) {
1259          %status = %{$param{status}};
1260      }
1261      else {
1262           my $location = getbuglocation($param{bug}, 'summary');
1263           return {} if not length $location;
1264           %status = %{ readbug( $param{bug}, $location ) };
1265      }
1266
1267      my @sourceversions;
1268      my $pseudo_desc = getpseudodesc();
1269      if (not exists $param{sourceversions}) {
1270           my %sourceversions;
1271           # pseudopackages do not have source versions by definition.
1272           if (exists $pseudo_desc->{$status{package}}) {
1273                # do nothing.
1274           }
1275           elsif (defined $param{version}) {
1276                foreach my $arch (make_list($param{arch})) {
1277                     for my $package (split /\s*,\s*/, $status{package}) {
1278                          my @temp = makesourceversions($package,
1279                                                        $arch,
1280                                                        make_list($param{version})
1281                                                       );
1282                          @sourceversions{@temp} = (1) x @temp;
1283                     }
1284                }
1285           } elsif (defined $param{dist}) {
1286                my %affects_distribution_tags;
1287                @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1288                     (1) x @{$config{affects_distribution_tags}};
1289                my $some_distributions_disallowed = 0;
1290                my %allowed_distributions;
1291                for my $tag (split ' ', ($status{keywords}||'')) {
1292                    if (exists $config{distribution_aliases}{$tag} and
1293                         exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1294                        $some_distributions_disallowed = 1;
1295                        $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1296                    }
1297                    elsif (exists $affects_distribution_tags{$tag}) {
1298                        $some_distributions_disallowed = 1;
1299                        $allowed_distributions{$tag} = 1;
1300                    }
1301                }
1302                my @archs = make_list(exists $param{arch}?$param{arch}:());
1303            GET_SOURCE_VERSIONS:
1304                foreach my $arch (@archs) {
1305                    for my $package (split /\s*,\s*/, $status{package}) {
1306                          my @versions = ();
1307                          my $source = 0;
1308                          if ($package =~ /^src:(.+)$/) {
1309                              $source = 1;
1310                              $package = $1;
1311                          }
1312                          foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1313                               # if some distributions are disallowed,
1314                               # and this isn't an allowed
1315                               # distribution, then we ignore this
1316                               # distribution for the purposees of
1317                               # finding versions
1318                               if ($some_distributions_disallowed and
1319                                   not exists $allowed_distributions{$dist}) {
1320                                    next;
1321                               }
1322                               push @versions, get_versions(package => $package,
1323                                                            dist    => $dist,
1324                                                            ($source?(arch => 'source'):
1325                                                             (defined $arch?(arch => $arch):())),
1326                                                           );
1327                          }
1328                          next unless @versions;
1329                          my @temp = make_source_versions(package => $package,
1330                                                          arch => $arch,
1331                                                          versions => \@versions,
1332                                                         );
1333                          @sourceversions{@temp} = (1) x @temp;
1334                     }
1335                }
1336                # this should really be split out into a subroutine,
1337                # but it'd touch so many things currently, that we fake
1338                # it; it's needed to properly handle bugs which are
1339                # erroneously assigned to the binary package, and we'll
1340                # probably have it go away eventually.
1341                if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1342                    @archs = (undef);
1343                    goto GET_SOURCE_VERSIONS;
1344                }
1345           }
1346
1347           # TODO: This should probably be handled further out for efficiency and
1348           # for more ease of distinguishing between pkg= and src= queries.
1349           # DLA: src= queries should just pass arch=source, and they'll be happy.
1350           @sourceversions = keys %sourceversions;
1351      }
1352      else {
1353           @sourceversions = @{$param{sourceversions}};
1354      }
1355      my $maxbuggy = 'undef';
1356      if (@sourceversions) {
1357           $maxbuggy = max_buggy(bug => $param{bug},
1358                                 sourceversions => \@sourceversions,
1359                                 found => $status{found_versions},
1360                                 fixed => $status{fixed_versions},
1361                                 package => $status{package},
1362                                 version_cache => $version_cache,
1363                                );
1364      }
1365      elsif (defined $param{dist} and
1366             not exists $pseudo_desc->{$status{package}}) {
1367           return 'absent';
1368      }
1369      if (length($status{done}) and
1370          (not @sourceversions or not @{$status{fixed_versions}})) {
1371           return 'fixed';
1372      }
1373      return $maxbuggy;
1374 }
1375
1376
1377 =head2 max_buggy
1378
1379      max_buggy()
1380
1381 =head3 Options
1382
1383 =over
1384
1385 =item bug -- scalar bug number
1386
1387 =item sourceversion -- optional arrayref of source/version; overrides
1388 dist, arch, and version. [The entries in this array must be in the
1389 "source/version" format.] Eventually this can be used to for caching.
1390
1391 =back
1392
1393 Note: Currently the version information is cached; this needs to be
1394 changed before using this function in long lived programs.
1395
1396
1397 =cut
1398 sub max_buggy{
1399      my %param = validate_with(params => \@_,
1400                                spec   => {bug       => {type => SCALAR,
1401                                                         regex => qr/^\d+$/,
1402                                                        },
1403                                           sourceversions => {type => ARRAYREF,
1404                                                              default => [],
1405                                                             },
1406                                           found          => {type => ARRAYREF,
1407                                                              default => [],
1408                                                             },
1409                                           fixed          => {type => ARRAYREF,
1410                                                              default => [],
1411                                                             },
1412                                           package        => {type => SCALAR,
1413                                                             },
1414                                           version_cache  => {type => HASHREF,
1415                                                              default => {},
1416                                                             },
1417                                          },
1418                               );
1419      # Resolve bugginess states (we might be looking at multiple
1420      # architectures, say). Found wins, then fixed, then absent.
1421      my $maxbuggy = 'absent';
1422      for my $package (split /\s*,\s*/, $param{package}) {
1423           for my $version (@{$param{sourceversions}}) {
1424                my $buggy = buggy(bug => $param{bug},
1425                                  version => $version,
1426                                  found => $param{found},
1427                                  fixed => $param{fixed},
1428                                  version_cache => $param{version_cache},
1429                                  package => $package,
1430                                 );
1431                if ($buggy eq 'found') {
1432                     return 'found';
1433                } elsif ($buggy eq 'fixed') {
1434                     $maxbuggy = 'fixed';
1435                }
1436           }
1437      }
1438      return $maxbuggy;
1439 }
1440
1441
1442 =head2 buggy
1443
1444      buggy(bug => nnn,
1445            found => \@found,
1446            fixed => \@fixed,
1447            package => 'foo',
1448            version => '1.0',
1449           );
1450
1451 Returns the output of Debbugs::Versions::buggy for a particular
1452 package, version and found/fixed set. Automatically turns found, fixed
1453 and version into source/version strings.
1454
1455 Caching can be had by using the version_cache, but no attempt to check
1456 to see if the on disk information is more recent than the cache is
1457 made. [This will need to be fixed for long-lived processes.]
1458
1459 =cut
1460
1461 sub buggy {
1462      my %param = validate_with(params => \@_,
1463                                spec   => {bug => {type => SCALAR,
1464                                                   regex => qr/^\d+$/,
1465                                                  },
1466                                           found => {type => ARRAYREF,
1467                                                     default => [],
1468                                                    },
1469                                           fixed => {type => ARRAYREF,
1470                                                     default => [],
1471                                                    },
1472                                           version_cache => {type => HASHREF,
1473                                                             optional => 1,
1474                                                            },
1475                                           package => {type => SCALAR,
1476                                                      },
1477                                           version => {type => SCALAR,
1478                                                      },
1479                                          },
1480                               );
1481      my @found = @{$param{found}};
1482      my @fixed = @{$param{fixed}};
1483      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1484           # We have non-source version versions
1485           @found = makesourceversions($param{package},undef,
1486                                       @found
1487                                      );
1488           @fixed = makesourceversions($param{package},undef,
1489                                       @fixed
1490                                      );
1491      }
1492      if ($param{version} !~ m{/}) {
1493           my ($version) = makesourceversions($param{package},undef,
1494                                              $param{version}
1495                                             );
1496           $param{version} = $version if defined $version;
1497      }
1498      # Figure out which source packages we need
1499      my %sources;
1500      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1501      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1502      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1503           $param{version} =~ m{/};
1504      my $version;
1505      if (not defined $param{version_cache} or
1506          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1507           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1508           foreach my $source (keys %sources) {
1509                my $srchash = substr $source, 0, 1;
1510                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1511                if (not defined $version_fh) {
1512                     # We only want to warn if it's a package which actually has a maintainer
1513                     my $maints = getmaintainers();
1514                     next if not exists $maints->{$source};
1515                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1516                     next;
1517                }
1518                $version->load($version_fh);
1519           }
1520           if (defined $param{version_cache}) {
1521                $param{version_cache}{join(',',sort keys %sources)} = $version;
1522           }
1523      }
1524      else {
1525           $version = $param{version_cache}{join(',',sort keys %sources)};
1526      }
1527      return $version->buggy($param{version},\@found,\@fixed);
1528 }
1529
1530 sub isstrongseverity {
1531     my $severity = shift;
1532     $severity = $config{default_severity} if
1533          not defined $severity or $severity eq '';
1534     return grep { $_ eq $severity } @{$config{strong_severities}};
1535 }
1536
1537
1538 =head1 PRIVATE FUNCTIONS
1539
1540 =cut
1541
1542 sub update_realtime {
1543         my ($file, %bugs) = @_;
1544
1545         # update realtime index.db
1546
1547         return () unless keys %bugs;
1548         my $idx_old = IO::File->new($file,'r')
1549              or die "Couldn't open ${file}: $!";
1550         my $idx_new = IO::File->new($file.'.new','w')
1551              or die "Couldn't open ${file}.new: $!";
1552
1553         my $min_bug = min(keys %bugs);
1554         my $line;
1555         my @line;
1556         my %changed_bugs;
1557         while($line = <$idx_old>) {
1558              @line = split /\s/, $line;
1559              # Two cases; replacing existing line or adding new line
1560              if (exists $bugs{$line[1]}) {
1561                   my $new = $bugs{$line[1]};
1562                   delete $bugs{$line[1]};
1563                   $min_bug = min(keys %bugs);
1564                   if ($new eq "NOCHANGE") {
1565                        print {$idx_new} $line;
1566                        $changed_bugs{$line[1]} = $line;
1567                   } elsif ($new eq "REMOVE") {
1568                        $changed_bugs{$line[1]} = $line;
1569                   } else {
1570                        print {$idx_new} $new;
1571                        $changed_bugs{$line[1]} = $line;
1572                   }
1573              }
1574              else {
1575                   while ($line[1] > $min_bug) {
1576                        print {$idx_new} $bugs{$min_bug};
1577                        delete $bugs{$min_bug};
1578                        last unless keys %bugs;
1579                        $min_bug = min(keys %bugs);
1580                   }
1581                   print {$idx_new} $line;
1582              }
1583              last unless keys %bugs;
1584         }
1585         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1586
1587         print {$idx_new} <$idx_old>;
1588
1589         close($idx_new);
1590         close($idx_old);
1591
1592         rename("$file.new", $file);
1593
1594         return %changed_bugs;
1595 }
1596
1597 sub bughook_archive {
1598         my @refs = @_;
1599         filelock("$config{spool_dir}/debbugs.trace.lock");
1600         appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1601         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1602                                    map{($_,'REMOVE')} @refs);
1603         update_realtime("$config{spool_dir}/index.archive.realtime",
1604                         %bugs);
1605         unfilelock();
1606 }
1607
1608 sub bughook {
1609         my ( $type, %bugs_temp ) = @_;
1610         filelock("$config{spool_dir}/debbugs.trace.lock");
1611
1612         my %bugs;
1613         for my $bug (keys %bugs_temp) {
1614              my $data = $bugs_temp{$bug};
1615              appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1616
1617              my $whendone = "open";
1618              my $severity = $config{default_severity};
1619              (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1620              $pkglist =~ s/^,+//;
1621              $pkglist =~ s/,+$//;
1622              $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1623              $whendone = "done" if defined $data->{done} and length $data->{done};
1624              $severity = $data->{severity} if length $data->{severity};
1625
1626              my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1627                   $pkglist, $bug, $data->{date}, $whendone,
1628                        $data->{originator}, $severity, $data->{keywords};
1629              $bugs{$bug} = $k;
1630         }
1631         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1632
1633         unfilelock();
1634 }
1635
1636
1637 1;
1638
1639 __END__