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