Debbugs/Status.pm

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