2 package Debbugs::Status;
6 Debbugs::Status -- Routines for dealing with summary and status files
15 This module is a replacement for the parts of errorlib.pl which write
16 and read status and summary files.
18 It also contains generic routines for returning information about the
19 status of a particular bug
27 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
28 use base qw(Exporter);
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;
41 $DEBUG = 0 unless defined $DEBUG;
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),
51 Exporter::export_ok_tags(qw(status read write versions));
52 $EXPORT_TAGS{all} = [@EXPORT_OK];
58 readbug($bug_number,$location)
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>
66 my %fields = (originator => 'submitter',
69 msgid => 'message-id',
70 'package' => 'package',
73 forwarded => 'forwarded-to',
74 mergedwith => 'merged-with',
75 severity => 'severity',
77 found_versions => 'found-in',
78 found_date => 'found-date',
79 fixed_versions => 'fixed-in',
80 fixed_date => 'fixed-date',
82 blockedby => 'blocked-by',
85 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
86 my @rfc1522_fields = qw(originator subject done forwarded owner);
90 readbug($bug_num,$location);
94 Retreives the information from the summary files for a particular bug
95 number. If location is not specified, getbuglocation is called to fill
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
105 my ($lref, $location) = @_;
106 if (not defined $location) {
107 $location = getbuglocation($lref,'summary');
108 return undef if not defined $location;
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;
120 while (<$status_fh>) {
123 $version = $1 if /^Format-Version: ([0-9]+)/i;
126 # Version 3 is the latest format version currently supported.
127 return undef if $version > 3;
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};
136 for my $field (keys %fields) {
137 $data{$field} = '' unless exists $data{$field};
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}];
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"}});
151 for my $field (@rfc1522_fields) {
152 $data{$field} = decode_rfc1522($data{$field});
161 lockreadbug($bug_num,$location)
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
167 See readbug above for information on what this returns
172 my ($lref, $location) = @_;
173 &filelock("lock/$lref");
174 my $data = readbug($lref, $location);
175 &unfilelock unless defined $data;
179 my @v1fieldorder = qw(originator date subject msgid package
180 keywords done forwarded mergedwith severity);
184 my $content = makestatus($status,$version)
185 my $content = makestatus($status);
187 Creates the content for a status file based on the $status hashref
190 Really only useful for writebug
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
199 my ($data,$version) = @_;
200 $version = 2 unless defined $version;
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}}];
212 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
213 $newdata{$field} = [split ' ', $newdata{$field}];
217 for my $field (@rfc1522_fields) {
218 $newdata{$field} = encode_rfc1522($newdata{$field});
223 for my $field (@v1fieldorder) {
224 if (exists $newdata{$field}) {
225 $contents .= "$newdata{$field}\n";
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";
249 writebug($bug_num,$status,$location,$minversion,$disablebughook)
251 Writes the bug status and summary files out.
253 Skips writting out a status file if minversion is 2
255 Does not call bughook if disablebughook is true.
260 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
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: $!");
277 rename("$status.new",$status) || &quit("installing new $status: $!");
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;
285 =head2 unlockwritebug
287 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
289 Writes a bug, then calls unfilelock; see writebug for what these
301 The following functions are exported with the :versions tag
303 =head2 addfoundversions
305 addfoundversions($status,$package,$version,$isbinary);
312 sub addfoundversions {
316 my $isbinary = shift;
317 return unless defined $version;
318 undef $package if $package =~ m[(?:\s|/)];
319 my $source = $package;
321 if (defined $package and $isbinary) {
322 my @srcinfo = binarytosource($package, $version, undef);
324 # We know the source package(s). Use a fully-qualified version.
325 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
328 # Otherwise, an unqualified version will have to do.
332 # Strip off various kinds of brain-damage.
334 $version =~ s/ *\(.*\)//;
335 $version =~ s/ +[A-Za-z].*//;
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;
342 @{$data->{fixed_versions}} =
343 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
347 sub removefoundversions {
351 my $isbinary = shift;
352 return unless defined $version;
353 undef $package if $package =~ m[(?:\s|/)];
354 my $source = $package;
356 if (defined $package and $isbinary) {
357 my @srcinfo = binarytosource($package, $version, undef);
359 # We know the source package(s). Use a fully-qualified version.
360 removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
363 # Otherwise, an unqualified version will have to do.
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}};
374 sub addfixedversions {
378 my $isbinary = shift;
379 return unless defined $version;
380 undef $package if $package =~ m[(?:\s|/)];
381 my $source = $package;
383 if (defined $package and $isbinary) {
384 my @srcinfo = binarytosource($package, $version, undef);
386 # We know the source package(s). Use a fully-qualified version.
387 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
390 # Otherwise, an unqualified version will have to do.
394 # Strip off various kinds of brain-damage.
396 $version =~ s/ *\(.*\)//;
397 $version =~ s/ +[A-Za-z].*//;
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;
404 @{$data->{found_versions}} =
405 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
409 sub removefixedversions {
413 my $isbinary = shift;
414 return unless defined $version;
415 undef $package if $package =~ m[(?:\s|/)];
416 my $source = $package;
418 if (defined $package and $isbinary) {
419 my @srcinfo = binarytosource($package, $version, undef);
421 # We know the source package(s). Use a fully-qualified version.
422 removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
425 # Otherwise, an unqualified version will have to do.
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}};
442 Split a package string from the status file into a list of package names.
448 return unless defined $pkgs;
449 return map lc, split /[ \t?,()]+/, $pkgs;
453 =head2 bug_archiveable
455 bug_archiveable(ref => $bug_num);
461 =item ref -- bug number (required)
463 =item status -- Status hashref (optional)
465 =item version -- Debbugs::Version information (optional)
467 =item days_until -- return days until the bug can be archived
471 Returns 1 if the bug can be archived
472 Returns 0 if the bug cannot be archived
474 If days_until is true, returns the number of days until the bug can be
475 archived, -1 if it cannot be archived.
480 my %param = validate_with(params => \@_,
481 spec => {ref => {type => SCALAR,
484 status => {type => HASHREF,
487 version => {type => HASHREF,
490 days_until => {type => BOOLEAN,
495 # read the status information
496 # read the version information
497 # Bugs can be archived if they are
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
506 =head1 PRIVATE FUNCTIONS
510 sub update_realtime {
511 my ($file, $bug, $new) = @_;
513 # update realtime index.db
515 open(IDXDB, "<$file") or die "Couldn't open $file";
516 open(IDXNEW, ">$file.new");
520 while($line = <IDXDB>) {
521 @line = split /\s/, $line;
522 last if ($line[1] >= $bug);
527 if ($new eq "NOCHANGE") {
528 print IDXNEW $line if ($line ne "" && $line[1] == $bug);
529 } elsif ($new eq "REMOVE") {
534 if ($line ne "" && $line[1] > $bug) {
539 print IDXNEW while(<IDXDB>);
544 rename("$file.new", $file);
549 sub bughook_archive {
551 &filelock("debbugs.trace.lock");
552 &appendfile("debbugs.trace","archive $ref\n");
553 my $line = update_realtime(
554 "$config{spool_dir}/index.db.realtime",
557 update_realtime("$config{spool_dir}/index.archive.realtime",
563 my ( $type, $ref, $data ) = @_;
564 &filelock("debbugs.trace.lock");
566 &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
568 my $whendone = "open";
569 my $severity = $config{default_severity};
570 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
573 $whendone = "forwarded" if length $data->{forwarded};
574 $whendone = "done" if length $data->{done};
575 $severity = $data->{severity} if length $data->{severity};
577 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
578 $pkglist, $ref, $data->{date}, $whendone,
579 $data->{originator}, $severity, $data->{keywords};
581 update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);
587 =head2 get_bug_status
589 my $status = get_bug_status(bug => $nnn);
591 my $status = get_bug_status($bug_num)
597 =item bug -- scalar bug number
599 =item status -- optional hashref of bug status as returned by readbug
600 (can be passed to avoid rereading the bug information)
602 =item bug_index -- optional tied index of bug status infomration;
603 currently not correctly implemented.
605 =item version -- optional version to check package status at
607 =item dist -- optional distribution to check package status at
609 =item arch -- optional architecture to check package status at
611 =item usertags -- optional hashref of usertags
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.
619 Note: Currently the version information is cached; this needs to be
620 changed before using this function in long lived programs.
624 # This will eventually need to be fixed before we start using mod_perl
625 my $version_cache = {};
630 my %param = validate_with(params => \@_,
631 spec => {bug => {type => SCALAR,
634 status => {type => HASHREF,
637 bug_index => {type => OBJECT,
640 version => {type => SCALAR,
643 dist => {type => SCALAR,
646 arch => {type => SCALAR,
649 usertags => {type => HASHREF,
652 sourceversions => {type => ARRAYREF,
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};
666 if (defined $param{status}) {
667 %status = %{$param{status}};
670 my $location = getbuglocation($param{bug}, 'summary');
671 return {} if not length $location;
672 %status = %{ readbug( $param{bug}, $location ) };
674 $status{id} = $param{bug};
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}}});
681 $status{tags} = $status{keywords};
682 my %tags = map { $_ => 1 } split ' ', $status{tags};
684 $status{"package"} =~ s/\s*$//;
685 $status{"package"} = 'unknown' if ($status{"package"} eq '');
686 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
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});
694 if (not exists $param{sourceversions}) {
696 if (defined $param{version}) {
697 @versions = ($param{version});
698 } elsif (defined $param{dist}) {
699 @versions = getversions($status{package}, $param{dist}, $param{arch});
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},
709 @sourceversions = @{$param{sourceversions}};
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},
719 found => $status{found_versions},
720 fixed => $status{fixed_versions},
721 version_cache => $version_cache,
722 package => $status{package},
724 if ($buggy eq 'found') {
727 } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
731 if ($maxbuggy eq 'absent') {
732 $status{"pending"} = 'absent';
733 } elsif ($maxbuggy eq 'fixed') {
734 $status{"pending"} = 'done';
738 if (length($status{done}) and
739 (not @sourceversions or not @{$status{fixed_versions}})) {
740 $status{"pending"} = 'done';
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.
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.]
766 my %param = validate_with(params => \@_,
767 spec => {bug => {type => SCALAR,
770 found => {type => ARRAYREF,
773 fixed => {type => ARRAYREF,
776 version_cache => {type => HASHREF,
779 package => {type => SCALAR,
781 version => {type => SCALAR,
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,
792 @fixed = makesourceversions($param{package},undef,
796 if ($param{version} !~ m{/}) {
797 $param{version} = makesourceversions($param{package},undef,
801 # Figure out which source packages we need
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;
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);
815 if (defined $param{version_cache}) {
816 $param{version_cache}{join(',',sort keys %sources)} = $version;
820 $version = $param{version_cache}{join(',',sort keys %sources)};
822 return $version->buggy($param{version},\@found,\@fixed);