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