Debbugs/Status.pm

   1
   2 package Debbugs::Status;
   3
   4 =head1 NAME
   5
   6 Debbugs::Status -- Routines for dealing with summary and status files
   7
   8 =head1 SYNOPSIS
   9
  10 use Debbugs::Status;
  11
  12
  13 =head1 DESCRIPTION
  14
  15 This module is a replacement for the parts of errorlib.pl which write
  16 and read status and summary files.
  17
  18 It also contains generic routines for returning information about the
  19 status of a particular bug
  20
  21 =head1 FUNCTIONS
  22
  23 =cut
  24
  25 use warnings;
  26 use strict;
  27 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  28 use base qw(Exporter);
  29
  30 use Params::Validate qw(validate_with :types);
  31 use Debbugs::Common qw(:util :lock);
  32 use Debbugs::Config qw(:config);
  33 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
  34 use Debbugs::Packages qw(makesourceversions getversions);
  35 use Debbugs::Versions;
  36 use Debbugs::Versions::Dpkg;
  37
  38
  39 BEGIN{
  40      $VERSION = 1.00;
  41      $DEBUG = 0 unless defined $DEBUG;
  42
  43      @EXPORT = ();
  44      %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy)],
  45                      read   => [qw(readbug lockreadbug)],
  46                      write  => [qw(writebug makestatus unlockwritebug)],
  47                      versions => [qw(addfoundversion addfixedversion),
  48                                  ],
  49                     );
  50      @EXPORT_OK = ();
  51      Exporter::export_ok_tags(qw(status read write versions));
  52      $EXPORT_TAGS{all} = [@EXPORT_OK];
  53 }
  54
  55
  56 =head2 readbug
  57
  58      readbug($bug_number,$location)
  59
  60 Reads a summary file from the archive given a bug number and a bug
  61 location. Valid locations are those understood by L</getbugcomponent>
  62
  63 =cut
  64
  65
  66 my %fields = (originator     => 'submitter',
  67               date           => 'date',
  68               subject        => 'subject',
  69               msgid          => 'message-id',
  70               'package'      => 'package',
  71               keywords       => 'tags',
  72               done           => 'done',
  73               forwarded      => 'forwarded-to',
  74               mergedwith     => 'merged-with',
  75               severity       => 'severity',
  76               owner          => 'owner',
  77               found_versions => 'found-in',
  78               found_date     => 'found-date',
  79               fixed_versions => 'fixed-in',
  80               fixed_date     => 'fixed-date',
  81               blocks         => 'blocks',
  82               blockedby      => 'blocked-by',
  83              );
  84
  85 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
  86 my @rfc1522_fields = qw(originator subject done forwarded owner);
  87
  88 =head2 readbug
  89
  90      readbug($bug_num,$location);
  91      readbug($bug_num)
  92
  93
  94 Retreives the information from the summary files for a particular bug
  95 number. If location is not specified, getbuglocation is called to fill
  96 it in.
  97
  98 =cut
  99
 100 # Sesse: ok, that I've moved to Debbugs::Status; I think I'm going to make a variant called read_bug that allows you to just say
 101 # read_bug(bugnum=>$nnn); and get back the right thing, or read_bug(path=>$nnn)
 102 # and then make readbug call read_bug with the right arguments
 103
 104 sub readbug {
 105     my ($lref, $location) = @_;
 106     if (not defined $location) {
 107          $location = getbuglocation($lref,'summary');
 108          return undef if not defined $location;
 109     }
 110     my $status = getbugcomponent($lref, 'summary', $location);
 111     return undef unless defined $status;
 112     my $status_fh = new IO::File $status, 'r' or
 113          warn "Unable to open $status for reading: $!" and return undef;
 114
 115     my %data;
 116     my @lines;
 117     my $version = 2;
 118     local $_;
 119
 120     while (<$status_fh>) {
 121         chomp;
 122         push @lines, $_;
 123         $version = $1 if /^Format-Version: ([0-9]+)/i;
 124     }
 125
 126     # Version 3 is the latest format version currently supported.
 127     return undef if $version > 3;
 128
 129     my %namemap = reverse %fields;
 130     for my $line (@lines) {
 131         if ($line =~ /(\S+?): (.*)/) {
 132             my ($name, $value) = (lc $1, $2);
 133             $data{$namemap{$name}} = $value if exists $namemap{$name};
 134         }
 135     }
 136     for my $field (keys %fields) {
 137         $data{$field} = '' unless exists $data{$field};
 138     }
 139
 140     $data{severity} = $config{default_severity} if $data{severity} eq '';
 141     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 142          $data{$field} = [split ' ', $data{$field}];
 143     }
 144     for my $field (qw(found fixed)) {
 145          @{$data{$field}}{@{$data{"${field}_versions"}}} =
 146               (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
 147                @{$data{"${field}_date"}});
 148     }
 149
 150     if ($version < 3) {
 151         for my $field (@rfc1522_fields) {
 152             $data{$field} = decode_rfc1522($data{$field});
 153         }
 154     }
 155
 156     return \%data;
 157 }
 158
 159 =head2 lockreadbug
 160
 161      lockreadbug($bug_num,$location)
 162
 163 Performs a filelock, then reads the bug; the bug is unlocked if the
 164 return is undefined, otherwise, you need to call unfilelock or
 165 unlockwritebug.
 166
 167 See readbug above for information on what this returns
 168
 169 =cut
 170
 171 sub lockreadbug {
 172     my ($lref, $location) = @_;
 173     &filelock("lock/$lref");
 174     my $data = readbug($lref, $location);
 175     &unfilelock unless defined $data;
 176     return $data;
 177 }
 178
 179 my @v1fieldorder = qw(originator date subject msgid package
 180                       keywords done forwarded mergedwith severity);
 181
 182 =head2 makestatus
 183
 184      my $content = makestatus($status,$version)
 185      my $content = makestatus($status);
 186
 187 Creates the content for a status file based on the $status hashref
 188 passed.
 189
 190 Really only useful for writebug
 191
 192 Currently defaults to version 2 (non-encoded rfc1522 names) but will
 193 eventually default to version 3. If you care, you should specify a
 194 version.
 195
 196 =cut
 197
 198 sub makestatus {
 199     my ($data,$version) = @_;
 200     $version = 2 unless defined $version;
 201
 202     my $contents = '';
 203
 204     my %newdata = %$data;
 205     for my $field (qw(found fixed)) {
 206          if (exists $newdata{$field}) {
 207               $newdata{"${field}_date"} =
 208                    [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
 209          }
 210     }
 211
 212     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 213          $newdata{$field} = [split ' ', $newdata{$field}];
 214     }
 215
 216     if ($version < 3) {
 217         for my $field (@rfc1522_fields) {
 218             $newdata{$field} = encode_rfc1522($newdata{$field});
 219         }
 220     }
 221
 222     if ($version == 1) {
 223         for my $field (@v1fieldorder) {
 224             if (exists $newdata{$field}) {
 225                 $contents .= "$newdata{$field}\n";
 226             } else {
 227                 $contents .= "\n";
 228             }
 229         }
 230     } elsif ($version == 2 or $version == 3) {
 231         # Version 2 or 3. Add a file format version number for the sake of
 232         # further extensibility in the future.
 233         $contents .= "Format-Version: $version\n";
 234         for my $field (keys %fields) {
 235             if (exists $newdata{$field} and $newdata{$field} ne '') {
 236                 # Output field names in proper case, e.g. 'Merged-With'.
 237                 my $properfield = $fields{$field};
 238                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 239                 $contents .= "$properfield: $newdata{$field}\n";
 240             }
 241         }
 242     }
 243
 244     return $contents;
 245 }
 246
 247 =head2 writebug
 248
 249      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 250
 251 Writes the bug status and summary files out.
 252
 253 Skips writting out a status file if minversion is 2
 254
 255 Does not call bughook if disablebughook is true.
 256
 257 =cut
 258
 259 sub writebug {
 260     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 261     my $change;
 262
 263     my %outputs = (1 => 'status', 2 => 'summary');
 264     for my $version (keys %outputs) {
 265         next if defined $minversion and $version < $minversion;
 266         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 267         &quit("can't find location for $ref") unless defined $status;
 268         open(S,"> $status.new") || &quit("opening $status.new: $!");
 269         print(S makestatus($data, $version)) ||
 270             &quit("writing $status.new: $!");
 271         close(S) || &quit("closing $status.new: $!");
 272         if (-e $status) {
 273             $change = 'change';
 274         } else {
 275             $change = 'new';
 276         }
 277         rename("$status.new",$status) || &quit("installing new $status: $!");
 278     }
 279
 280     # $disablebughook is a bit of a hack to let format migration scripts use
 281     # this function rather than having to duplicate it themselves.
 282     &bughook($change,$ref,$data) unless $disablebughook;
 283 }
 284
 285 =head2 unlockwritebug
 286
 287      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 288
 289 Writes a bug, then calls unfilelock; see writebug for what these
 290 options mean.
 291
 292 =cut
 293
 294 sub unlockwritebug {
 295     writebug(@_);
 296     &unfilelock;
 297 }
 298
 299 =head1 VERSIONS
 300
 301 The following functions are exported with the :versions tag
 302
 303 =head2 addfoundversions
 304
 305      addfoundversions($status,$package,$version,$isbinary);
 306
 307
 308
 309 =cut
 310
 311
 312 sub addfoundversions {
 313     my $data = shift;
 314     my $package = shift;
 315     my $version = shift;
 316     my $isbinary = shift;
 317     return unless defined $version;
 318     undef $package if $package =~ m[(?:\s|/)];
 319     my $source = $package;
 320
 321     if (defined $package and $isbinary) {
 322         my @srcinfo = binarytosource($package, $version, undef);
 323         if (@srcinfo) {
 324             # We know the source package(s). Use a fully-qualified version.
 325             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 326             return;
 327         }
 328         # Otherwise, an unqualified version will have to do.
 329         undef $source;
 330     }
 331
 332     # Strip off various kinds of brain-damage.
 333     $version =~ s/;.*//;
 334     $version =~ s/ *\(.*\)//;
 335     $version =~ s/ +[A-Za-z].*//;
 336
 337     foreach my $ver (split /[,\s]+/, $version) {
 338         my $sver = defined($source) ? "$source/$ver" : '';
 339         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 340             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 341         }
 342         @{$data->{fixed_versions}} =
 343             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 344     }
 345 }
 346
 347 sub removefoundversions {
 348     my $data = shift;
 349     my $package = shift;
 350     my $version = shift;
 351     my $isbinary = shift;
 352     return unless defined $version;
 353     undef $package if $package =~ m[(?:\s|/)];
 354     my $source = $package;
 355
 356     if (defined $package and $isbinary) {
 357         my @srcinfo = binarytosource($package, $version, undef);
 358         if (@srcinfo) {
 359             # We know the source package(s). Use a fully-qualified version.
 360             removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 361             return;
 362         }
 363         # Otherwise, an unqualified version will have to do.
 364         undef $source;
 365     }
 366
 367     foreach my $ver (split /[,\s]+/, $version) {
 368         my $sver = defined($source) ? "$source/$ver" : '';
 369         @{$data->{found_versions}} =
 370             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 371     }
 372 }
 373
 374 sub addfixedversions {
 375     my $data = shift;
 376     my $package = shift;
 377     my $version = shift;
 378     my $isbinary = shift;
 379     return unless defined $version;
 380     undef $package if $package =~ m[(?:\s|/)];
 381     my $source = $package;
 382
 383     if (defined $package and $isbinary) {
 384         my @srcinfo = binarytosource($package, $version, undef);
 385         if (@srcinfo) {
 386             # We know the source package(s). Use a fully-qualified version.
 387             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 388             return;
 389         }
 390         # Otherwise, an unqualified version will have to do.
 391         undef $source;
 392     }
 393
 394     # Strip off various kinds of brain-damage.
 395     $version =~ s/;.*//;
 396     $version =~ s/ *\(.*\)//;
 397     $version =~ s/ +[A-Za-z].*//;
 398
 399     foreach my $ver (split /[,\s]+/, $version) {
 400         my $sver = defined($source) ? "$source/$ver" : '';
 401         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 402             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 403         }
 404         @{$data->{found_versions}} =
 405             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 406     }
 407 }
 408
 409 sub removefixedversions {
 410     my $data = shift;
 411     my $package = shift;
 412     my $version = shift;
 413     my $isbinary = shift;
 414     return unless defined $version;
 415     undef $package if $package =~ m[(?:\s|/)];
 416     my $source = $package;
 417
 418     if (defined $package and $isbinary) {
 419         my @srcinfo = binarytosource($package, $version, undef);
 420         if (@srcinfo) {
 421             # We know the source package(s). Use a fully-qualified version.
 422             removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 423             return;
 424         }
 425         # Otherwise, an unqualified version will have to do.
 426         undef $source;
 427     }
 428
 429     foreach my $ver (split /[,\s]+/, $version) {
 430         my $sver = defined($source) ? "$source/$ver" : '';
 431         @{$data->{fixed_versions}} =
 432             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 433     }
 434 }
 435
 436
 437
 438 =head2 splitpackages
 439
 440      splitpackages($pkgs)
 441
 442 Split a package string from the status file into a list of package names.
 443
 444 =cut
 445
 446 sub splitpackages {
 447     my $pkgs = shift;
 448     return unless defined $pkgs;
 449     return map lc, split /[ \t?,()]+/, $pkgs;
 450 }
 451
 452
 453 =head2 bug_archiveable
 454
 455      bug_archiveable(ref => $bug_num);
 456
 457 Options
 458
 459 =over
 460
 461 =item ref -- bug number (required)
 462
 463 =item status -- Status hashref (optional)
 464
 465 =item version -- Debbugs::Version information (optional)
 466
 467 =item days_until -- return days until the bug can be archived
 468
 469 =back
 470
 471 Returns 1 if the bug can be archived
 472 Returns 0 if the bug cannot be archived
 473
 474 If days_until is true, returns the number of days until the bug can be
 475 archived, -1 if it cannot be archived.
 476
 477 =cut
 478
 479 sub bug_archiveable{
 480      my %param = validate_with(params => \@_,
 481                                spec   => {ref => {type => SCALAR,
 482                                                   regex => qr/^\d+$/,
 483                                                  },
 484                                           status => {type => HASHREF,
 485                                                      optional => 1,
 486                                                     },
 487                                           version => {type => HASHREF,
 488                                                       optional => 1,
 489                                                      },
 490                                           days_until => {type => BOOLEAN,
 491                                                          default => 0,
 492                                                         },
 493                                          },
 494                               );
 495      # read the status information
 496      # read the version information
 497      # Bugs can be archived if they are
 498      # 1. Closed
 499      # 2. Fixed in unstable if tagged unstable
 500      # 3. Fixed in stable if tagged stable
 501      # 4. Fixed in testing if tagged testing
 502      # 5. Fixed in experimental if tagged experimental
 503      # 6. at least 28 days have passed since the last action has occured or the bug was closed
 504 }
 505
 506 =head1 PRIVATE FUNCTIONS
 507
 508 =cut
 509
 510 sub update_realtime {
 511         my ($file, $bug, $new) = @_;
 512
 513         # update realtime index.db
 514
 515         open(IDXDB, "<$file") or die "Couldn't open $file";
 516         open(IDXNEW, ">$file.new");
 517
 518         my $line;
 519         my @line;
 520         while($line = <IDXDB>) {
 521                 @line = split /\s/, $line;
 522                 last if ($line[1] >= $bug);
 523                 print IDXNEW $line;
 524                 $line = "";
 525         }
 526
 527         if ($new eq "NOCHANGE") {
 528                 print IDXNEW $line if ($line ne "" && $line[1] == $bug);
 529         } elsif ($new eq "REMOVE") {
 530                 0;
 531         } else {
 532                 print IDXNEW $new;
 533         }
 534         if ($line ne "" && $line[1] > $bug) {
 535                 print IDXNEW $line;
 536                 $line = "";
 537         }
 538
 539         print IDXNEW while(<IDXDB>);
 540
 541         close(IDXNEW);
 542         close(IDXDB);
 543
 544         rename("$file.new", $file);
 545
 546         return $line;
 547 }
 548
 549 sub bughook_archive {
 550         my $ref = shift;
 551         &filelock("debbugs.trace.lock");
 552         &appendfile("debbugs.trace","archive $ref\n");
 553         my $line = update_realtime(
 554                 "$config{spool_dir}/index.db.realtime",
 555                 $ref,
 556                 "REMOVE");
 557         update_realtime("$config{spool_dir}/index.archive.realtime",
 558                 $ref, $line);
 559         &unfilelock;
 560 }
 561
 562 sub bughook {
 563         my ( $type, $ref, $data ) = @_;
 564         &filelock("debbugs.trace.lock");
 565
 566         &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
 567
 568         my $whendone = "open";
 569         my $severity = $config{default_severity};
 570         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
 571         $pkglist =~ s/^,+//;
 572         $pkglist =~ s/,+$//;
 573         $whendone = "forwarded" if length $data->{forwarded};
 574         $whendone = "done" if length $data->{done};
 575         $severity = $data->{severity} if length $data->{severity};
 576
 577         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 578                         $pkglist, $ref, $data->{date}, $whendone,
 579                         $data->{originator}, $severity, $data->{keywords};
 580
 581         update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);
 582
 583         &unfilelock;
 584 }
 585
 586
 587 =head2 get_bug_status
 588
 589      my $status = get_bug_status(bug => $nnn);
 590
 591      my $status = get_bug_status($bug_num)
 592
 593 =head3 Options
 594
 595 =over
 596
 597 =item bug -- scalar bug number
 598
 599 =item status -- optional hashref of bug status as returned by readbug
 600 (can be passed to avoid rereading the bug information)
 601
 602 =item bug_index -- optional tied index of bug status infomration;
 603 currently not correctly implemented.
 604
 605 =item version -- optional version to check package status at
 606
 607 =item dist -- optional distribution to check package status at
 608
 609 =item arch -- optional architecture to check package status at
 610
 611 =item usertags -- optional hashref of usertags
 612
 613 =item sourceversion -- optional arrayref of source/version; overrides
 614 dist, arch, and version. [The entries in this array must be in the
 615 "source/version" format.] Eventually this can be used to for caching.
 616
 617 =back
 618
 619 Note: Currently the version information is cached; this needs to be
 620 changed before using this function in long lived programs.
 621
 622 =cut
 623
 624 # This will eventually need to be fixed before we start using mod_perl
 625 my $version_cache = {};
 626 sub get_bug_status {
 627      if (@_ == 1) {
 628           unshift @_, 'bug';
 629      }
 630      my %param = validate_with(params => \@_,
 631                                spec   => {bug       => {type => SCALAR,
 632                                                         regex => qr/^\d+$/,
 633                                                        },
 634                                           status    => {type => HASHREF,
 635                                                         optional => 1,
 636                                                        },
 637                                           bug_index => {type => OBJECT,
 638                                                         optional => 1,
 639                                                        },
 640                                           version   => {type => SCALAR,
 641                                                         optional => 1,
 642                                                        },
 643                                           dist       => {type => SCALAR,
 644                                                          optional => 1,
 645                                                         },
 646                                           arch       => {type => SCALAR,
 647                                                          optional => 1,
 648                                                         },
 649                                           usertags   => {type => HASHREF,
 650                                                          optional => 1,
 651                                                         },
 652                                           sourceversions => {type => ARRAYREF,
 653                                                              optional => 1,
 654                                                             },
 655                                          },
 656                               );
 657      my %status;
 658
 659      if (defined $param{bug_index} and
 660          exists $param{bug_index}{$param{bug}}) {
 661           %status = %{ $param{bug_index}{$param{bug}} };
 662           $status{pending} = $status{ status };
 663           $status{id} = $param{bug};
 664           return \%status;
 665      }
 666      if (defined $param{status}) {
 667           %status = %{$param{status}};
 668      }
 669      else {
 670           my $location = getbuglocation($param{bug}, 'summary');
 671           return {} if not length $location;
 672           %status = %{ readbug( $param{bug}, $location ) };
 673      }
 674      $status{id} = $param{bug};
 675
 676      if (defined $param{usertags}{$param{bug}}) {
 677           $status{keywords} = "" unless defined $status{keywords};
 678           $status{keywords} .= " " unless $status{keywords} eq "";
 679           $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}});
 680      }
 681      $status{tags} = $status{keywords};
 682      my %tags = map { $_ => 1 } split ' ', $status{tags};
 683
 684      $status{"package"} =~ s/\s*$//;
 685      $status{"package"} = 'unknown' if ($status{"package"} eq '');
 686      $status{"severity"} = 'normal' if ($status{"severity"} eq '');
 687
 688      $status{"pending"} = 'pending';
 689      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
 690      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
 691      $status{"pending"} = 'fixed'           if ($tags{fixed});
 692
 693      my @sourceversions;
 694      if (not exists $param{sourceversions}) {
 695           my @versions;
 696           if (defined $param{version}) {
 697                @versions = ($param{version});
 698           } elsif (defined $param{dist}) {
 699                @versions = getversions($status{package}, $param{dist}, $param{arch});
 700           }
 701
 702           # TODO: This should probably be handled further out for efficiency and
 703           # for more ease of distinguishing between pkg= and src= queries.
 704           @sourceversions = makesourceversions($status{package},
 705                                                $param{arch},
 706                                                @versions);
 707      }
 708      else {
 709           @sourceversions = @{$param{sourceversions}};
 710      }
 711
 712      if (@sourceversions) {
 713           # Resolve bugginess states (we might be looking at multiple
 714           # architectures, say). Found wins, then fixed, then absent.
 715           my $maxbuggy = 'absent';
 716           for my $version (@sourceversions) {
 717                my $buggy = buggy(bug => $param{bug},
 718                                  version => $version,
 719                                  found => $status{found_versions},
 720                                  fixed => $status{fixed_versions},
 721                                  version_cache => $version_cache,
 722                                  package => $status{package},
 723                                 );
 724                if ($buggy eq 'found') {
 725                     $maxbuggy = 'found';
 726                     last;
 727                } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
 728                     $maxbuggy = 'fixed';
 729                }
 730           }
 731           if ($maxbuggy eq 'absent') {
 732                $status{"pending"} = 'absent';
 733           } elsif ($maxbuggy eq 'fixed') {
 734                $status{"pending"} = 'done';
 735           }
 736      }
 737
 738      if (length($status{done}) and
 739          (not @sourceversions or not @{$status{fixed_versions}})) {
 740           $status{"pending"} = 'done';
 741      }
 742
 743      return \%status;
 744 }
 745
 746 =head2 buggy
 747
 748      buggy(bug => nnn,
 749            found => \@found,
 750            fixed => \@fixed,
 751            package => 'foo',
 752            version => '1.0',
 753           );
 754
 755 Returns the output of Debbugs::Versions::buggy for a particular
 756 package, version and found/fixed set. Automatically turns found, fixed
 757 and version into source/version strings.
 758
 759 Caching can be had by using the version_cache, but no attempt to check
 760 to see if the on disk information is more recent than the cache is
 761 made. [This will need to be fixed for long-lived processes.]
 762
 763 =cut
 764
 765 sub buggy {
 766      my %param = validate_with(params => \@_,
 767                                spec   => {bug => {type => SCALAR,
 768                                                   regex => qr/^\d+$/,
 769                                                  },
 770                                           found => {type => ARRAYREF,
 771                                                     default => [],
 772                                                    },
 773                                           fixed => {type => ARRAYREF,
 774                                                     default => [],
 775                                                    },
 776                                           version_cache => {type => HASHREF,
 777                                                             optional => 1,
 778                                                            },
 779                                           package => {type => SCALAR,
 780                                                      },
 781                                           version => {type => SCALAR,
 782                                                      },
 783                                          },
 784                               );
 785      my @found = @{$param{found}};
 786      my @fixed = @{$param{fixed}};
 787      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
 788           # We have non-source version versions
 789           @found = makesourceversions($param{package},undef,
 790                                       @found
 791                                      );
 792           @fixed = makesourceversions($param{package},undef,
 793                                       @fixed
 794                                      );
 795      }
 796      if ($param{version} !~ m{/}) {
 797           $param{version} = makesourceversions($param{package},undef,
 798                                                $param{version}
 799                                               );
 800      }
 801      # Figure out which source packages we need
 802      my %sources;
 803      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
 804      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
 805      @sources{map {m{(.+)/}; $1} $param{version}} = 1;
 806      my $version;
 807      if (not defined $param{version_cache} or
 808          not exists $param{version_cache}{join(',',sort keys %sources)}) {
 809           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
 810           foreach my $source (keys %sources) {
 811                my $srchash = substr $source, 0, 1;
 812                my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
 813                $version->load($version_fh);
 814           }
 815           if (defined $param{version_cache}) {
 816                $param{version_cache}{join(',',sort keys %sources)} = $version;
 817           }
 818      }
 819      else {
 820           $version = $param{version_cache}{join(',',sort keys %sources)};
 821      }
 822      return $version->buggy($param{version},\@found,\@fixed);
 823 }
 824
 825
 826 1;
 827
 828 __END__