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