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