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 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 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  36 use base qw(Exporter);
  37
  38 use Params::Validate qw(validate_with :types);
  39 use Debbugs::Common qw(:util :lock :quit :misc);
  40 use Debbugs::Config qw(:config);
  41 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
  42 use Debbugs::Packages qw(makesourceversions getversions get_versions binarytosource);
  43 use Debbugs::Versions;
  44 use Debbugs::Versions::Dpkg;
  45 use POSIX qw(ceil);
  46
  47
  48 BEGIN{
  49      $VERSION = 1.00;
  50      $DEBUG = 0 unless defined $DEBUG;
  51
  52      @EXPORT = ();
  53      %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
  54                                 qw(isstrongseverity bug_presence),
  55                                ],
  56                      read   => [qw(readbug read_bug lockreadbug)],
  57                      write  => [qw(writebug makestatus unlockwritebug)],
  58                      versions => [qw(addfoundversions addfixedversions),
  59                                   qw(removefoundversions removefixedversions)
  60                                  ],
  61                      hook     => [qw(bughook bughook_archive)],
  62                     );
  63      @EXPORT_OK = ();
  64      Exporter::export_ok_tags(qw(status read write versions hook));
  65      $EXPORT_TAGS{all} = [@EXPORT_OK];
  66 }
  67
  68
  69 =head2 readbug
  70
  71      readbug($bug_num,$location)
  72      readbug($bug_num)
  73
  74 Reads a summary file from the archive given a bug number and a bug
  75 location. Valid locations are those understood by L</getbugcomponent>
  76
  77 =cut
  78
  79
  80 my %fields = (originator     => 'submitter',
  81               date           => 'date',
  82               subject        => 'subject',
  83               msgid          => 'message-id',
  84               'package'      => 'package',
  85               keywords       => 'tags',
  86               done           => 'done',
  87               forwarded      => 'forwarded-to',
  88               mergedwith     => 'merged-with',
  89               severity       => 'severity',
  90               owner          => 'owner',
  91               found_versions => 'found-in',
  92               found_date     => 'found-date',
  93               fixed_versions => 'fixed-in',
  94               fixed_date     => 'fixed-date',
  95               blocks         => 'blocks',
  96               blockedby      => 'blocked-by',
  97              );
  98
  99 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
 100 my @rfc1522_fields = qw(originator subject done forwarded owner);
 101
 102 sub readbug {
 103      return read_bug(bug => $_[0],
 104                      (@_ > 1)?(location => $_[1]):()
 105                     );
 106 }
 107
 108 =head2 read_bug
 109
 110      read_bug(bug => $bug_num,
 111               location => 'archive',
 112              );
 113      read_bug(summary => 'path/to/bugnum.summary');
 114      read_bug($bug_num);
 115
 116 A more complete function than readbug; it enables you to pass a full
 117 path to the summary file instead of the bug number and/or location.
 118
 119 =head3 Options
 120
 121 =over
 122
 123 =item bug -- the bug number
 124
 125 =item location -- optional location which is passed to getbugcomponent
 126
 127 =item summary -- complete path to the .summary file which will be read
 128
 129 =back
 130
 131 One of C<bug> or C<summary> must be passed. This function will return
 132 undef on failure, and will die if improper arguments are passed.
 133
 134 =cut
 135
 136 sub read_bug{
 137     if (@_ == 1) {
 138          unshift @_, 'bug';
 139     }
 140     my %param = validate_with(params => \@_,
 141                               spec   => {bug => {type => SCALAR,
 142                                                  optional => 1,
 143                                                  # something really
 144                                                  # stupid passes
 145                                                  # negative bugnumbers
 146                                                  regex    => qr/^-?\d+/,
 147                                                 },
 148                                          location => {type => SCALAR|UNDEF,
 149                                                       optional => 1,
 150                                                      },
 151                                          summary  => {type => SCALAR,
 152                                                       optional => 1,
 153                                                      },
 154                                         },
 155                              );
 156     die "One of bug or summary must be passed to read_bug"
 157          if not exists $param{bug} and not exists $param{summary};
 158     my $status;
 159     if (not defined $param{summary}) {
 160          my ($lref, $location) = @param{qw(bug location)};
 161          if (not defined $location) {
 162               $location = getbuglocation($lref,'summary');
 163               return undef if not defined $location;
 164          }
 165          $status = getbugcomponent($lref, 'summary', $location);
 166          return undef unless defined $status;
 167     }
 168     else {
 169          $status = $param{summary};
 170     }
 171     my $status_fh = new IO::File $status, 'r' or
 172          warn "Unable to open $status for reading: $!" and return undef;
 173
 174     my %data;
 175     my @lines;
 176     my $version = 2;
 177     local $_;
 178
 179     while (<$status_fh>) {
 180         chomp;
 181         push @lines, $_;
 182         $version = $1 if /^Format-Version: ([0-9]+)/i;
 183     }
 184
 185     # Version 3 is the latest format version currently supported.
 186     return undef if $version > 3;
 187
 188     my %namemap = reverse %fields;
 189     for my $line (@lines) {
 190         if ($line =~ /(\S+?): (.*)/) {
 191             my ($name, $value) = (lc $1, $2);
 192             $data{$namemap{$name}} = $value if exists $namemap{$name};
 193         }
 194     }
 195     for my $field (keys %fields) {
 196         $data{$field} = '' unless exists $data{$field};
 197     }
 198
 199     $data{severity} = $config{default_severity} if $data{severity} eq '';
 200     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 201          $data{$field} = [split ' ', $data{$field}];
 202     }
 203     for my $field (qw(found fixed)) {
 204          # create the found/fixed hashes which indicate when a
 205          # particular version was marked found or marked fixed.
 206          @{$data{$field}}{@{$data{"${field}_versions"}}} =
 207               (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
 208                @{$data{"${field}_date"}});
 209     }
 210
 211     if ($version < 3) {
 212         for my $field (@rfc1522_fields) {
 213             $data{$field} = decode_rfc1522($data{$field});
 214         }
 215     }
 216
 217     return \%data;
 218 }
 219
 220 =head2 lockreadbug
 221
 222      lockreadbug($bug_num,$location)
 223
 224 Performs a filelock, then reads the bug; the bug is unlocked if the
 225 return is undefined, otherwise, you need to call unfilelock or
 226 unlockwritebug.
 227
 228 See readbug above for information on what this returns
 229
 230 =cut
 231
 232 sub lockreadbug {
 233     my ($lref, $location) = @_;
 234     &filelock("lock/$lref");
 235     my $data = read_bug(bug => $lref, location => $location);
 236     &unfilelock unless defined $data;
 237     return $data;
 238 }
 239
 240 my @v1fieldorder = qw(originator date subject msgid package
 241                       keywords done forwarded mergedwith severity);
 242
 243 =head2 makestatus
 244
 245      my $content = makestatus($status,$version)
 246      my $content = makestatus($status);
 247
 248 Creates the content for a status file based on the $status hashref
 249 passed.
 250
 251 Really only useful for writebug
 252
 253 Currently defaults to version 2 (non-encoded rfc1522 names) but will
 254 eventually default to version 3. If you care, you should specify a
 255 version.
 256
 257 =cut
 258
 259 sub makestatus {
 260     my ($data,$version) = @_;
 261     $version = 2 unless defined $version;
 262
 263     my $contents = '';
 264
 265     my %newdata = %$data;
 266     for my $field (qw(found fixed)) {
 267          if (exists $newdata{$field}) {
 268               $newdata{"${field}_date"} =
 269                    [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
 270          }
 271     }
 272
 273     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 274          $newdata{$field} = join ' ', @{$newdata{$field}||[]};
 275     }
 276
 277     if ($version < 3) {
 278         for my $field (@rfc1522_fields) {
 279             $newdata{$field} = encode_rfc1522($newdata{$field});
 280         }
 281     }
 282
 283     if ($version == 1) {
 284         for my $field (@v1fieldorder) {
 285             if (exists $newdata{$field} and defined $newdata{$field}) {
 286                 $contents .= "$newdata{$field}\n";
 287             } else {
 288                 $contents .= "\n";
 289             }
 290         }
 291     } elsif ($version == 2 or $version == 3) {
 292         # Version 2 or 3. Add a file format version number for the sake of
 293         # further extensibility in the future.
 294         $contents .= "Format-Version: $version\n";
 295         for my $field (keys %fields) {
 296             if (exists $newdata{$field} and defined $newdata{$field}
 297                 and $newdata{$field} ne '') {
 298                 # Output field names in proper case, e.g. 'Merged-With'.
 299                 my $properfield = $fields{$field};
 300                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 301                 $contents .= "$properfield: $newdata{$field}\n";
 302             }
 303         }
 304     }
 305
 306     return $contents;
 307 }
 308
 309 =head2 writebug
 310
 311      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 312
 313 Writes the bug status and summary files out.
 314
 315 Skips writting out a status file if minversion is 2
 316
 317 Does not call bughook if disablebughook is true.
 318
 319 =cut
 320
 321 sub writebug {
 322     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 323     my $change;
 324
 325     my %outputs = (1 => 'status', 2 => 'summary');
 326     for my $version (keys %outputs) {
 327         next if defined $minversion and $version < $minversion;
 328         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 329         &quit("can't find location for $ref") unless defined $status;
 330         open(S,"> $status.new") || &quit("opening $status.new: $!");
 331         print(S makestatus($data, $version)) ||
 332             &quit("writing $status.new: $!");
 333         close(S) || &quit("closing $status.new: $!");
 334         if (-e $status) {
 335             $change = 'change';
 336         } else {
 337             $change = 'new';
 338         }
 339         rename("$status.new",$status) || &quit("installing new $status: $!");
 340     }
 341
 342     # $disablebughook is a bit of a hack to let format migration scripts use
 343     # this function rather than having to duplicate it themselves.
 344     &bughook($change,$ref,$data) unless $disablebughook;
 345 }
 346
 347 =head2 unlockwritebug
 348
 349      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 350
 351 Writes a bug, then calls unfilelock; see writebug for what these
 352 options mean.
 353
 354 =cut
 355
 356 sub unlockwritebug {
 357     writebug(@_);
 358     &unfilelock;
 359 }
 360
 361 =head1 VERSIONS
 362
 363 The following functions are exported with the :versions tag
 364
 365 =head2 addfoundversions
 366
 367      addfoundversions($status,$package,$version,$isbinary);
 368
 369
 370
 371 =cut
 372
 373
 374 sub addfoundversions {
 375     my $data = shift;
 376     my $package = shift;
 377     my $version = shift;
 378     my $isbinary = shift;
 379     return unless defined $version;
 380     undef $package if $package =~ m[(?:\s|/)];
 381     my $source = $package;
 382
 383     if (defined $package and $isbinary) {
 384         my @srcinfo = binarytosource($package, $version, undef);
 385         if (@srcinfo) {
 386             # We know the source package(s). Use a fully-qualified version.
 387             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 388             return;
 389         }
 390         # Otherwise, an unqualified version will have to do.
 391         undef $source;
 392     }
 393
 394     # Strip off various kinds of brain-damage.
 395     $version =~ s/;.*//;
 396     $version =~ s/ *\(.*\)//;
 397     $version =~ s/ +[A-Za-z].*//;
 398
 399     foreach my $ver (split /[,\s]+/, $version) {
 400         my $sver = defined($source) ? "$source/$ver" : '';
 401         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 402             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 403         }
 404         @{$data->{fixed_versions}} =
 405             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 406     }
 407 }
 408
 409 =head2 removefoundversions
 410
 411      removefoundversions($data,$package,$versiontoremove)
 412
 413 Removes found versions from $data
 414
 415 If a version is fully qualified (contains /) only versions matching
 416 exactly are removed. Otherwise, all versions matching the version
 417 number are removed.
 418
 419 Currently $package and $isbinary are entirely ignored, but accepted
 420 for backwards compatibilty.
 421
 422 =cut
 423
 424 sub removefoundversions {
 425     my $data = shift;
 426     my $package = shift;
 427     my $version = shift;
 428     my $isbinary = shift;
 429     return unless defined $version;
 430
 431     foreach my $ver (split /[,\s]+/, $version) {
 432          if ($ver =~ m{/}) {
 433               # fully qualified version
 434               @{$data->{found_versions}} =
 435                    grep {$_ ne $ver}
 436                         @{$data->{found_versions}};
 437          }
 438          else {
 439               # non qualified version; delete all matchers
 440               @{$data->{found_versions}} =
 441                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 442                         @{$data->{found_versions}};
 443          }
 444     }
 445 }
 446
 447
 448 sub addfixedversions {
 449     my $data = shift;
 450     my $package = shift;
 451     my $version = shift;
 452     my $isbinary = shift;
 453     return unless defined $version;
 454     undef $package if defined $package and $package =~ m[(?:\s|/)];
 455     my $source = $package;
 456
 457     if (defined $package and $isbinary) {
 458         my @srcinfo = binarytosource($package, $version, undef);
 459         if (@srcinfo) {
 460             # We know the source package(s). Use a fully-qualified version.
 461             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 462             return;
 463         }
 464         # Otherwise, an unqualified version will have to do.
 465         undef $source;
 466     }
 467
 468     # Strip off various kinds of brain-damage.
 469     $version =~ s/;.*//;
 470     $version =~ s/ *\(.*\)//;
 471     $version =~ s/ +[A-Za-z].*//;
 472
 473     foreach my $ver (split /[,\s]+/, $version) {
 474         my $sver = defined($source) ? "$source/$ver" : '';
 475         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 476             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 477         }
 478         @{$data->{found_versions}} =
 479             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 480     }
 481 }
 482
 483 sub removefixedversions {
 484     my $data = shift;
 485     my $package = shift;
 486     my $version = shift;
 487     my $isbinary = shift;
 488     return unless defined $version;
 489     undef $package if $package =~ m[(?:\s|/)];
 490     my $source = $package;
 491
 492     if (defined $package and $isbinary) {
 493         my @srcinfo = binarytosource($package, $version, undef);
 494         if (@srcinfo) {
 495             # We know the source package(s). Use a fully-qualified version.
 496             removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 497             return;
 498         }
 499         # Otherwise, an unqualified version will have to do.
 500         undef $source;
 501     }
 502
 503     foreach my $ver (split /[,\s]+/, $version) {
 504         my $sver = defined($source) ? "$source/$ver" : '';
 505         @{$data->{fixed_versions}} =
 506             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 507     }
 508 }
 509
 510
 511
 512 =head2 splitpackages
 513
 514      splitpackages($pkgs)
 515
 516 Split a package string from the status file into a list of package names.
 517
 518 =cut
 519
 520 sub splitpackages {
 521     my $pkgs = shift;
 522     return unless defined $pkgs;
 523     return map lc, split /[ \t?,()]+/, $pkgs;
 524 }
 525
 526
 527 =head2 bug_archiveable
 528
 529      bug_archiveable(bug => $bug_num);
 530
 531 Options
 532
 533 =over
 534
 535 =item bug -- bug number (required)
 536
 537 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
 538
 539 =item version -- Debbugs::Version information (optional)
 540
 541 =item days_until -- return days until the bug can be archived
 542
 543 =back
 544
 545 Returns 1 if the bug can be archived
 546 Returns 0 if the bug cannot be archived
 547
 548 If days_until is true, returns the number of days until the bug can be
 549 archived, -1 if it cannot be archived. 0 means that the bug can be
 550 archived the next time the archiver runs.
 551
 552 Returns undef on failure.
 553
 554 =cut
 555
 556 # This will eventually need to be fixed before we start using mod_perl
 557 our $version_cache = {};
 558 sub bug_archiveable{
 559      my %param = validate_with(params => \@_,
 560                                spec   => {bug => {type => SCALAR,
 561                                                   regex => qr/^\d+$/,
 562                                                  },
 563                                           status => {type => HASHREF,
 564                                                      optional => 1,
 565                                                     },
 566                                           days_until => {type => BOOLEAN,
 567                                                          default => 0,
 568                                                         },
 569                                          },
 570                               );
 571      # This is what we return if the bug cannot be archived.
 572      my $cannot_archive = $param{days_until}?-1:0;
 573      # read the status information
 574      my $status = $param{status};
 575      if (not exists $param{status} or not defined $status) {
 576           $status = read_bug(bug=>$param{bug});
 577           return undef if not defined $status;
 578      }
 579      # Bugs can be archived if they are
 580      # 1. Closed
 581      return $cannot_archive if not defined $status->{done} or not length $status->{done};
 582      # If we just are checking if the bug can be archived, we'll not even bother
 583      # checking the versioning information if the bug has been -done for less than 28 days.
 584      if (not $param{days_until} and $config{remove_age} >
 585          -M getbugcomponent($param{ref},'log')
 586         ) {
 587           return $cannot_archive;
 588      }
 589      # At this point, we have to get the versioning information for this bug.
 590      # We examine the set of distribution tags. If a bug has no distribution
 591      # tags set, we assume a default set, otherwise we use the tags the bug
 592      # has set.
 593
 594      # There must be fixed_versions for us to look at the versioning
 595      # information
 596      if (@{$status->{fixed_versions}}) {
 597           my %dist_tags;
 598           @dist_tags{@{$config{removal_distribution_tags}}} =
 599                (1) x @{$config{removal_distribution_tags}};
 600           my %dists;
 601           @dists{@{$config{removal_default_distribution_tags}}} =
 602                (1) x @{$config{removal_default_distribution_tags}};
 603           for my $tag (split ' ', $status->{tags}) {
 604                next unless $dist_tags{$tag};
 605                $dists{$tag} = 1;
 606           }
 607           my %source_versions;
 608           my @sourceversions = get_versions(package => $status->{package},
 609                                             dist => [keys %dists],
 610                                             source => 1,
 611                                            );
 612           @source_versions{@sourceversions} = (1) x @sourceversions;
 613           if ('found' eq max_buggy(bug => $param{bug},
 614                                    sourceversions => [keys %source_versions],
 615                                    found          => $status->{found_versions},
 616                                    fixed          => $status->{fixed_versions},
 617                                    version_cache  => $version_cache,
 618                                    package        => $status->{package},
 619                                   )) {
 620                return $cannot_archive;
 621           }
 622           # Since the bug has at least been fixed in the architectures
 623           # that matters, we check to see how long it has been fixed.
 624
 625      }
 626      # 6. at least 28 days have passed since the last action has occured or the bug was closed
 627      my $age = ceil($config{remove_age} - -M getbugcomponent($param{bug},'log'));
 628      if ($age > 0 ) {
 629           return $param{days_until}?$age:0;
 630      }
 631      else {
 632           return $param{days_until}?0:1;
 633      }
 634 }
 635
 636
 637 =head2 get_bug_status
 638
 639      my $status = get_bug_status(bug => $nnn);
 640
 641      my $status = get_bug_status($bug_num)
 642
 643 =head3 Options
 644
 645 =over
 646
 647 =item bug -- scalar bug number
 648
 649 =item status -- optional hashref of bug status as returned by readbug
 650 (can be passed to avoid rereading the bug information)
 651
 652 =item bug_index -- optional tied index of bug status infomration;
 653 currently not correctly implemented.
 654
 655 =item version -- optional version(s) to check package status at
 656
 657 =item dist -- optional distribution(s) to check package status at
 658
 659 =item arch -- optional architecture(s) to check package status at
 660
 661 =item usertags -- optional hashref of usertags
 662
 663 =item sourceversion -- optional arrayref of source/version; overrides
 664 dist, arch, and version. [The entries in this array must be in the
 665 "source/version" format.] Eventually this can be used to for caching.
 666
 667 =back
 668
 669 Note: Currently the version information is cached; this needs to be
 670 changed before using this function in long lived programs.
 671
 672 =cut
 673
 674 sub get_bug_status {
 675      if (@_ == 1) {
 676           unshift @_, 'bug';
 677      }
 678      my %param = validate_with(params => \@_,
 679                                spec   => {bug       => {type => SCALAR,
 680                                                         regex => qr/^\d+$/,
 681                                                        },
 682                                           status    => {type => HASHREF,
 683                                                         optional => 1,
 684                                                        },
 685                                           bug_index => {type => OBJECT,
 686                                                         optional => 1,
 687                                                        },
 688                                           version   => {type => SCALAR|ARRAYREF,
 689                                                         optional => 1,
 690                                                        },
 691                                           dist       => {type => SCALAR|ARRAYREF,
 692                                                          optional => 1,
 693                                                         },
 694                                           arch       => {type => SCALAR|ARRAYREF,
 695                                                          optional => 1,
 696                                                         },
 697                                           usertags   => {type => HASHREF,
 698                                                          optional => 1,
 699                                                         },
 700                                           sourceversions => {type => ARRAYREF,
 701                                                              optional => 1,
 702                                                             },
 703                                          },
 704                               );
 705      my %status;
 706
 707      if (defined $param{bug_index} and
 708          exists $param{bug_index}{$param{bug}}) {
 709           %status = %{ $param{bug_index}{$param{bug}} };
 710           $status{pending} = $status{ status };
 711           $status{id} = $param{bug};
 712           return \%status;
 713      }
 714      if (defined $param{status}) {
 715           %status = %{$param{status}};
 716      }
 717      else {
 718           my $location = getbuglocation($param{bug}, 'summary');
 719           return {} if not length $location;
 720           %status = %{ readbug( $param{bug}, $location ) };
 721      }
 722      $status{id} = $param{bug};
 723
 724      if (defined $param{usertags}{$param{bug}}) {
 725           $status{keywords} = "" unless defined $status{keywords};
 726           $status{keywords} .= " " unless $status{keywords} eq "";
 727           $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}});
 728      }
 729      $status{tags} = $status{keywords};
 730      my %tags = map { $_ => 1 } split ' ', $status{tags};
 731
 732      $status{"package"} =~ s/\s*$//;
 733      $status{"package"} = 'unknown' if ($status{"package"} eq '');
 734      $status{"severity"} = 'normal' if ($status{"severity"} eq '');
 735
 736      $status{"pending"} = 'pending';
 737      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
 738      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
 739      $status{"pending"} = 'fixed'           if ($tags{fixed});
 740
 741
 742      my $presence = bug_presence(map{(exists $param{$_})?($_,$param{$_}):()}
 743                                  qw(bug sourceversions arch dist version found fixed package)
 744                                 );
 745      if (defined $presence) {
 746           if ($presence eq 'fixed') {
 747                $status{pending} = 'done';
 748           }
 749           elsif ($presence eq 'absent') {
 750                $status{pending} = 'absent';
 751           }
 752      }
 753      return \%status;
 754 }
 755
 756 =head2 bug_presence
 757
 758      my $precence = bug_presence(bug => nnn,
 759                                  ...
 760                                 );
 761
 762 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
 763 is found, absent, fixed, or no information is available in the
 764 distribution (dist) and/or architecture (arch) specified.
 765
 766
 767 =head3 Options
 768
 769 =over
 770
 771 =item bug -- scalar bug number
 772
 773 =item status -- optional hashref of bug status as returned by readbug
 774 (can be passed to avoid rereading the bug information)
 775
 776 =item bug_index -- optional tied index of bug status infomration;
 777 currently not correctly implemented.
 778
 779 =item version -- optional version to check package status at
 780
 781 =item dist -- optional distribution to check package status at
 782
 783 =item arch -- optional architecture to check package status at
 784
 785 =item sourceversion -- optional arrayref of source/version; overrides
 786 dist, arch, and version. [The entries in this array must be in the
 787 "source/version" format.] Eventually this can be used to for caching.
 788
 789 =back
 790
 791 =cut
 792
 793 sub bug_presence {
 794      my %param = validate_with(params => \@_,
 795                                spec   => {bug       => {type => SCALAR,
 796                                                         regex => qr/^\d+$/,
 797                                                        },
 798                                           status    => {type => HASHREF,
 799                                                         optional => 1,
 800                                                        },
 801                                           version   => {type => SCALAR|ARRAYREF,
 802                                                         optional => 1,
 803                                                        },
 804                                           dist       => {type => SCALAR|ARRAYREF,
 805                                                          optional => 1,
 806                                                         },
 807                                           arch       => {type => SCALAR|ARRAYREF,
 808                                                          optional => 1,
 809                                                         },
 810                                           sourceversions => {type => ARRAYREF,
 811                                                              optional => 1,
 812                                                             },
 813                                          },
 814                               );
 815      my %status;
 816      if (defined $param{status}) {
 817          %status = %{$param{status}};
 818      }
 819      else {
 820           my $location = getbuglocation($param{bug}, 'summary');
 821           return {} if not length $location;
 822           %status = %{ readbug( $param{bug}, $location ) };
 823      }
 824
 825      my @sourceversions;
 826      if (not exists $param{sourceversions}) {
 827           my %sourceversions;
 828           if (defined $param{version}) {
 829                foreach my $arch (make_list($param{arch})) {
 830                     my @temp = makesourceversions($status{package},
 831                                                   $arch,
 832                                                   make_list($param{version})
 833                                                  );
 834                     @sourceversions{@temp} = (1) x @temp;
 835                }
 836           } elsif (defined $param{dist}) {
 837                foreach my $arch (make_list($param{arch})) {
 838                     my @versions;
 839                     foreach my $dist (make_list($param{dist})) {
 840                          push @versions, getversions($status{package}, $dist, $arch);
 841                     }
 842                     my @temp = makesourceversions($status{package},
 843                                                   $arch,
 844                                                   @versions
 845                                                  );
 846                     @sourceversions{@temp} = (1) x @temp;
 847                }
 848           }
 849
 850           # TODO: This should probably be handled further out for efficiency and
 851           # for more ease of distinguishing between pkg= and src= queries.
 852           @sourceversions = keys %sourceversions;
 853      }
 854      else {
 855           @sourceversions = @{$param{sourceversions}};
 856      }
 857      my $maxbuggy = 'undef';
 858      if (@sourceversions) {
 859           $maxbuggy = max_buggy(bug => $param{bug},
 860                                    sourceversions => \@sourceversions,
 861                                    found => $status{found_versions},
 862                                    fixed => $status{fixed_versions},
 863                                    package => $status{package},
 864                                    version_cache => $version_cache,
 865                                   );
 866      }
 867      elsif (defined $param{dist}) {
 868           return 'absent';
 869      }
 870      if (length($status{done}) and
 871          (not @sourceversions or not @{$status{fixed_versions}})) {
 872           return 'fixed';
 873      }
 874      return $maxbuggy;
 875 }
 876
 877
 878 =head2 max_buggy
 879
 880      max_buggy()
 881
 882 =head3 Options
 883
 884 =over
 885
 886 =item bug -- scalar bug number
 887
 888 =item sourceversion -- optional arrayref of source/version; overrides
 889 dist, arch, and version. [The entries in this array must be in the
 890 "source/version" format.] Eventually this can be used to for caching.
 891
 892 =back
 893
 894 Note: Currently the version information is cached; this needs to be
 895 changed before using this function in long lived programs.
 896
 897
 898 =cut
 899 sub max_buggy{
 900      my %param = validate_with(params => \@_,
 901                                spec   => {bug       => {type => SCALAR,
 902                                                         regex => qr/^\d+$/,
 903                                                        },
 904                                           sourceversions => {type => ARRAYREF,
 905                                                              default => [],
 906                                                             },
 907                                           found          => {type => ARRAYREF,
 908                                                              default => [],
 909                                                             },
 910                                           fixed          => {type => ARRAYREF,
 911                                                              default => [],
 912                                                             },
 913                                           package        => {type => SCALAR,
 914                                                             },
 915                                           version_cache  => {type => HASHREF,
 916                                                              default => {},
 917                                                             },
 918                                          },
 919                               );
 920      # Resolve bugginess states (we might be looking at multiple
 921      # architectures, say). Found wins, then fixed, then absent.
 922      my $maxbuggy = 'absent';
 923      for my $version (@{$param{sourceversions}}) {
 924           my $buggy = buggy(bug => $param{bug},
 925                             version => $version,
 926                             found => $param{found},
 927                             fixed => $param{fixed},
 928                             version_cache => $param{version_cache},
 929                             package => $param{package},
 930                            );
 931           if ($buggy eq 'found') {
 932                return 'found';
 933           } elsif ($buggy eq 'fixed') {
 934                $maxbuggy = 'fixed';
 935           }
 936      }
 937      return $maxbuggy;
 938 }
 939
 940
 941 =head2 buggy
 942
 943      buggy(bug => nnn,
 944            found => \@found,
 945            fixed => \@fixed,
 946            package => 'foo',
 947            version => '1.0',
 948           );
 949
 950 Returns the output of Debbugs::Versions::buggy for a particular
 951 package, version and found/fixed set. Automatically turns found, fixed
 952 and version into source/version strings.
 953
 954 Caching can be had by using the version_cache, but no attempt to check
 955 to see if the on disk information is more recent than the cache is
 956 made. [This will need to be fixed for long-lived processes.]
 957
 958 =cut
 959
 960 sub buggy {
 961      my %param = validate_with(params => \@_,
 962                                spec   => {bug => {type => SCALAR,
 963                                                   regex => qr/^\d+$/,
 964                                                  },
 965                                           found => {type => ARRAYREF,
 966                                                     default => [],
 967                                                    },
 968                                           fixed => {type => ARRAYREF,
 969                                                     default => [],
 970                                                    },
 971                                           version_cache => {type => HASHREF,
 972                                                             optional => 1,
 973                                                            },
 974                                           package => {type => SCALAR,
 975                                                      },
 976                                           version => {type => SCALAR,
 977                                                      },
 978                                          },
 979                               );
 980      my @found = @{$param{found}};
 981      my @fixed = @{$param{fixed}};
 982      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
 983           # We have non-source version versions
 984           @found = makesourceversions($param{package},undef,
 985                                       @found
 986                                      );
 987           @fixed = makesourceversions($param{package},undef,
 988                                       @fixed
 989                                      );
 990      }
 991      if ($param{version} !~ m{/}) {
 992           $param{version} = makesourceversions($param{package},undef,
 993                                                $param{version}
 994                                               );
 995      }
 996      # Figure out which source packages we need
 997      my %sources;
 998      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
 999      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1000      @sources{map {m{(.+)/}; $1} $param{version}} = 1;
1001      my $version;
1002      if (not defined $param{version_cache} or
1003          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1004           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1005           foreach my $source (keys %sources) {
1006                my $srchash = substr $source, 0, 1;
1007                my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r' or
1008                     warn "Unable to open $config{version_packages_dir}/$srchash/$source: $!" and next;
1009                $version->load($version_fh);
1010           }
1011           if (defined $param{version_cache}) {
1012                $param{version_cache}{join(',',sort keys %sources)} = $version;
1013           }
1014      }
1015      else {
1016           $version = $param{version_cache}{join(',',sort keys %sources)};
1017      }
1018      return $version->buggy($param{version},\@found,\@fixed);
1019 }
1020
1021 sub isstrongseverity {
1022     my $severity = shift;
1023     $severity = $config{default_severity} if $severity eq '';
1024     return grep { $_ eq $severity } @{$config{strong_severities}};
1025 }
1026
1027
1028 =head1 PRIVATE FUNCTIONS
1029
1030 =cut
1031
1032 sub update_realtime {
1033         my ($file, $bug, $new) = @_;
1034
1035         # update realtime index.db
1036
1037         open(IDXDB, "<$file") or die "Couldn't open $file";
1038         open(IDXNEW, ">$file.new");
1039
1040         my $line;
1041         my @line;
1042         while($line = <IDXDB>) {
1043                 @line = split /\s/, $line;
1044                 last if ($line[1] >= $bug);
1045                 print IDXNEW $line;
1046                 $line = "";
1047         }
1048
1049         if ($new eq "NOCHANGE") {
1050                 print IDXNEW $line if ($line ne ""  and $line[1] == $bug);
1051         } elsif ($new eq "REMOVE") {
1052                 0;
1053         } else {
1054                 print IDXNEW $new;
1055         }
1056         if (defined $line and $line ne "" and  @line and $line[1] > $bug) {
1057                 print IDXNEW $line;
1058                 $line = "";
1059         }
1060
1061         print IDXNEW while(<IDXDB>);
1062
1063         close(IDXNEW);
1064         close(IDXDB);
1065
1066         rename("$file.new", $file);
1067
1068         return $line;
1069 }
1070
1071 sub bughook_archive {
1072         my $ref = shift;
1073         &filelock("debbugs.trace.lock");
1074         &appendfile("debbugs.trace","archive $ref\n");
1075         my $line = update_realtime(
1076                 "$config{spool_dir}/index.db.realtime",
1077                 $ref,
1078                 "REMOVE");
1079         update_realtime("$config{spool_dir}/index.archive.realtime",
1080                 $ref, $line);
1081         &unfilelock;
1082 }
1083
1084 sub bughook {
1085         my ( $type, $ref, $data ) = @_;
1086         &filelock("debbugs.trace.lock");
1087
1088         &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
1089
1090         my $whendone = "open";
1091         my $severity = $config{default_severity};
1092         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1093         $pkglist =~ s/^,+//;
1094         $pkglist =~ s/,+$//;
1095         $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1096         $whendone = "done" if defined $data->{done} and length $data->{done};
1097         $severity = $data->{severity} if length $data->{severity};
1098
1099         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1100                         $pkglist, $ref, $data->{date}, $whendone,
1101                         $data->{originator}, $severity, $data->{keywords};
1102
1103         update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);
1104
1105         &unfilelock;
1106 }
1107
1108
1109 1;
1110
1111 __END__