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