Debbugs/Status.pm

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