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_num,$location)
61 Reads a summary file from the archive given a bug number and a bug
62 location. Valid locations are those understood by L</getbugcomponent>
67 my %fields = (originator => 'submitter',
70 msgid => 'message-id',
71 'package' => 'package',
74 forwarded => 'forwarded-to',
75 mergedwith => 'merged-with',
76 severity => 'severity',
78 found_versions => 'found-in',
79 found_date => 'found-date',
80 fixed_versions => 'fixed-in',
81 fixed_date => 'fixed-date',
83 blockedby => 'blocked-by',
86 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
87 my @rfc1522_fields = qw(originator subject done forwarded owner);
90 return read_bug(bug => $_[0],
91 (@_ > 1)?(location => $_[1]):()
97 read_bug(bug => $bug_num,
98 location => 'archive',
100 read_bug(summary => 'path/to/bugnum.summary');
103 A more complete function than readbug; it enables you to pass a full
104 path to the summary file instead of the bug number and/or location.
110 =item bug -- the bug number
112 =item location -- optional location which is passed to getbugcomponent
114 =item summary -- complete path to the .summary file which will be read
118 One of C<bug> or C<summary> must be passed. This function will return
119 undef on failure, and will die if improper arguments are passed.
127 my %param = validate_with(params => \@_,
128 spec => {bug => {type => SCALAR,
132 location => {type => SCALAR,
135 summary => {type => SCALAR,
140 die "One of bug or summary must be passed to read_bug"
141 if not exists $param{bug} and not exists $param{summary};
143 if (not defined $param{summary}) {
144 my ($lref, $location) = @param{qw(bug location)};
145 if (not defined $location) {
146 $location = getbuglocation($lref,'summary');
147 return undef if not defined $location;
149 $status = getbugcomponent($lref, 'summary', $location);
150 return undef unless defined $status;
153 $status = $param{summary};
155 my $status_fh = new IO::File $status, 'r' or
156 warn "Unable to open $status for reading: $!" and return undef;
163 while (<$status_fh>) {
166 $version = $1 if /^Format-Version: ([0-9]+)/i;
169 # Version 3 is the latest format version currently supported.
170 return undef if $version > 3;
172 my %namemap = reverse %fields;
173 for my $line (@lines) {
174 if ($line =~ /(\S+?): (.*)/) {
175 my ($name, $value) = (lc $1, $2);
176 $data{$namemap{$name}} = $value if exists $namemap{$name};
179 for my $field (keys %fields) {
180 $data{$field} = '' unless exists $data{$field};
183 $data{severity} = $config{default_severity} if $data{severity} eq '';
184 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
185 $data{$field} = [split ' ', $data{$field}];
187 for my $field (qw(found fixed)) {
188 @{$data{$field}}{@{$data{"${field}_versions"}}} =
189 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
190 @{$data{"${field}_date"}});
194 for my $field (@rfc1522_fields) {
195 $data{$field} = decode_rfc1522($data{$field});
204 lockreadbug($bug_num,$location)
206 Performs a filelock, then reads the bug; the bug is unlocked if the
207 return is undefined, otherwise, you need to call unfilelock or
210 See readbug above for information on what this returns
215 my ($lref, $location) = @_;
216 &filelock("lock/$lref");
217 my $data = read_bug(bug => $lref, location => $location);
218 &unfilelock unless defined $data;
222 my @v1fieldorder = qw(originator date subject msgid package
223 keywords done forwarded mergedwith severity);
227 my $content = makestatus($status,$version)
228 my $content = makestatus($status);
230 Creates the content for a status file based on the $status hashref
233 Really only useful for writebug
235 Currently defaults to version 2 (non-encoded rfc1522 names) but will
236 eventually default to version 3. If you care, you should specify a
242 my ($data,$version) = @_;
243 $version = 2 unless defined $version;
247 my %newdata = %$data;
248 for my $field (qw(found fixed)) {
249 if (exists $newdata{$field}) {
250 $newdata{"${field}_date"} =
251 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
255 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
256 $newdata{$field} = [split ' ', $newdata{$field}];
260 for my $field (@rfc1522_fields) {
261 $newdata{$field} = encode_rfc1522($newdata{$field});
266 for my $field (@v1fieldorder) {
267 if (exists $newdata{$field}) {
268 $contents .= "$newdata{$field}\n";
273 } elsif ($version == 2 or $version == 3) {
274 # Version 2 or 3. Add a file format version number for the sake of
275 # further extensibility in the future.
276 $contents .= "Format-Version: $version\n";
277 for my $field (keys %fields) {
278 if (exists $newdata{$field} and $newdata{$field} ne '') {
279 # Output field names in proper case, e.g. 'Merged-With'.
280 my $properfield = $fields{$field};
281 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
282 $contents .= "$properfield: $newdata{$field}\n";
292 writebug($bug_num,$status,$location,$minversion,$disablebughook)
294 Writes the bug status and summary files out.
296 Skips writting out a status file if minversion is 2
298 Does not call bughook if disablebughook is true.
303 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
306 my %outputs = (1 => 'status', 2 => 'summary');
307 for my $version (keys %outputs) {
308 next if defined $minversion and $version < $minversion;
309 my $status = getbugcomponent($ref, $outputs{$version}, $location);
310 &quit("can't find location for $ref") unless defined $status;
311 open(S,"> $status.new") || &quit("opening $status.new: $!");
312 print(S makestatus($data, $version)) ||
313 &quit("writing $status.new: $!");
314 close(S) || &quit("closing $status.new: $!");
320 rename("$status.new",$status) || &quit("installing new $status: $!");
323 # $disablebughook is a bit of a hack to let format migration scripts use
324 # this function rather than having to duplicate it themselves.
325 &bughook($change,$ref,$data) unless $disablebughook;
328 =head2 unlockwritebug
330 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
332 Writes a bug, then calls unfilelock; see writebug for what these
344 The following functions are exported with the :versions tag
346 =head2 addfoundversions
348 addfoundversions($status,$package,$version,$isbinary);
355 sub addfoundversions {
359 my $isbinary = shift;
360 return unless defined $version;
361 undef $package if $package =~ m[(?:\s|/)];
362 my $source = $package;
364 if (defined $package and $isbinary) {
365 my @srcinfo = binarytosource($package, $version, undef);
367 # We know the source package(s). Use a fully-qualified version.
368 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
371 # Otherwise, an unqualified version will have to do.
375 # Strip off various kinds of brain-damage.
377 $version =~ s/ *\(.*\)//;
378 $version =~ s/ +[A-Za-z].*//;
380 foreach my $ver (split /[,\s]+/, $version) {
381 my $sver = defined($source) ? "$source/$ver" : '';
382 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
383 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
385 @{$data->{fixed_versions}} =
386 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
390 sub removefoundversions {
394 my $isbinary = shift;
395 return unless defined $version;
396 undef $package if $package =~ m[(?:\s|/)];
397 my $source = $package;
399 if (defined $package and $isbinary) {
400 my @srcinfo = binarytosource($package, $version, undef);
402 # We know the source package(s). Use a fully-qualified version.
403 removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
406 # Otherwise, an unqualified version will have to do.
410 foreach my $ver (split /[,\s]+/, $version) {
411 my $sver = defined($source) ? "$source/$ver" : '';
412 @{$data->{found_versions}} =
413 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
417 sub addfixedversions {
421 my $isbinary = shift;
422 return unless defined $version;
423 undef $package if $package =~ m[(?:\s|/)];
424 my $source = $package;
426 if (defined $package and $isbinary) {
427 my @srcinfo = binarytosource($package, $version, undef);
429 # We know the source package(s). Use a fully-qualified version.
430 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
433 # Otherwise, an unqualified version will have to do.
437 # Strip off various kinds of brain-damage.
439 $version =~ s/ *\(.*\)//;
440 $version =~ s/ +[A-Za-z].*//;
442 foreach my $ver (split /[,\s]+/, $version) {
443 my $sver = defined($source) ? "$source/$ver" : '';
444 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
445 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
447 @{$data->{found_versions}} =
448 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
452 sub removefixedversions {
456 my $isbinary = shift;
457 return unless defined $version;
458 undef $package if $package =~ m[(?:\s|/)];
459 my $source = $package;
461 if (defined $package and $isbinary) {
462 my @srcinfo = binarytosource($package, $version, undef);
464 # We know the source package(s). Use a fully-qualified version.
465 removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
468 # Otherwise, an unqualified version will have to do.
472 foreach my $ver (split /[,\s]+/, $version) {
473 my $sver = defined($source) ? "$source/$ver" : '';
474 @{$data->{fixed_versions}} =
475 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
485 Split a package string from the status file into a list of package names.
491 return unless defined $pkgs;
492 return map lc, split /[ \t?,()]+/, $pkgs;
496 =head2 bug_archiveable
498 bug_archiveable(ref => $bug_num);
504 =item ref -- bug number (required)
506 =item status -- Status hashref (optional)
508 =item version -- Debbugs::Version information (optional)
510 =item days_until -- return days until the bug can be archived
514 Returns 1 if the bug can be archived
515 Returns 0 if the bug cannot be archived
517 If days_until is true, returns the number of days until the bug can be
518 archived, -1 if it cannot be archived.
523 my %param = validate_with(params => \@_,
524 spec => {ref => {type => SCALAR,
527 status => {type => HASHREF,
530 version => {type => HASHREF,
533 days_until => {type => BOOLEAN,
538 # read the status information
539 # read the version information
540 # Bugs can be archived if they are
542 # 2. Fixed in unstable if tagged unstable
543 # 3. Fixed in stable if tagged stable
544 # 4. Fixed in testing if tagged testing
545 # 5. Fixed in experimental if tagged experimental
546 # 6. at least 28 days have passed since the last action has occured or the bug was closed
549 =head1 PRIVATE FUNCTIONS
553 sub update_realtime {
554 my ($file, $bug, $new) = @_;
556 # update realtime index.db
558 open(IDXDB, "<$file") or die "Couldn't open $file";
559 open(IDXNEW, ">$file.new");
563 while($line = <IDXDB>) {
564 @line = split /\s/, $line;
565 last if ($line[1] >= $bug);
570 if ($new eq "NOCHANGE") {
571 print IDXNEW $line if ($line ne "" && $line[1] == $bug);
572 } elsif ($new eq "REMOVE") {
577 if ($line ne "" && $line[1] > $bug) {
582 print IDXNEW while(<IDXDB>);
587 rename("$file.new", $file);
592 sub bughook_archive {
594 &filelock("debbugs.trace.lock");
595 &appendfile("debbugs.trace","archive $ref\n");
596 my $line = update_realtime(
597 "$config{spool_dir}/index.db.realtime",
600 update_realtime("$config{spool_dir}/index.archive.realtime",
606 my ( $type, $ref, $data ) = @_;
607 &filelock("debbugs.trace.lock");
609 &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
611 my $whendone = "open";
612 my $severity = $config{default_severity};
613 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
616 $whendone = "forwarded" if length $data->{forwarded};
617 $whendone = "done" if length $data->{done};
618 $severity = $data->{severity} if length $data->{severity};
620 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
621 $pkglist, $ref, $data->{date}, $whendone,
622 $data->{originator}, $severity, $data->{keywords};
624 update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);
630 =head2 get_bug_status
632 my $status = get_bug_status(bug => $nnn);
634 my $status = get_bug_status($bug_num)
640 =item bug -- scalar bug number
642 =item status -- optional hashref of bug status as returned by readbug
643 (can be passed to avoid rereading the bug information)
645 =item bug_index -- optional tied index of bug status infomration;
646 currently not correctly implemented.
648 =item version -- optional version to check package status at
650 =item dist -- optional distribution to check package status at
652 =item arch -- optional architecture to check package status at
654 =item usertags -- optional hashref of usertags
656 =item sourceversion -- optional arrayref of source/version; overrides
657 dist, arch, and version. [The entries in this array must be in the
658 "source/version" format.] Eventually this can be used to for caching.
662 Note: Currently the version information is cached; this needs to be
663 changed before using this function in long lived programs.
667 # This will eventually need to be fixed before we start using mod_perl
668 my $version_cache = {};
673 my %param = validate_with(params => \@_,
674 spec => {bug => {type => SCALAR,
677 status => {type => HASHREF,
680 bug_index => {type => OBJECT,
683 version => {type => SCALAR,
686 dist => {type => SCALAR,
689 arch => {type => SCALAR,
692 usertags => {type => HASHREF,
695 sourceversions => {type => ARRAYREF,
702 if (defined $param{bug_index} and
703 exists $param{bug_index}{$param{bug}}) {
704 %status = %{ $param{bug_index}{$param{bug}} };
705 $status{pending} = $status{ status };
706 $status{id} = $param{bug};
709 if (defined $param{status}) {
710 %status = %{$param{status}};
713 my $location = getbuglocation($param{bug}, 'summary');
714 return {} if not length $location;
715 %status = %{ readbug( $param{bug}, $location ) };
717 $status{id} = $param{bug};
719 if (defined $param{usertags}{$param{bug}}) {
720 $status{keywords} = "" unless defined $status{keywords};
721 $status{keywords} .= " " unless $status{keywords} eq "";
722 $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}});
724 $status{tags} = $status{keywords};
725 my %tags = map { $_ => 1 } split ' ', $status{tags};
727 $status{"package"} =~ s/\s*$//;
728 $status{"package"} = 'unknown' if ($status{"package"} eq '');
729 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
731 $status{"pending"} = 'pending';
732 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
733 $status{"pending"} = 'pending-fixed' if ($tags{pending});
734 $status{"pending"} = 'fixed' if ($tags{fixed});
737 if (not exists $param{sourceversions}) {
739 if (defined $param{version}) {
740 @versions = ($param{version});
741 } elsif (defined $param{dist}) {
742 @versions = getversions($status{package}, $param{dist}, $param{arch});
745 # TODO: This should probably be handled further out for efficiency and
746 # for more ease of distinguishing between pkg= and src= queries.
747 @sourceversions = makesourceversions($status{package},
752 @sourceversions = @{$param{sourceversions}};
755 if (@sourceversions) {
756 # Resolve bugginess states (we might be looking at multiple
757 # architectures, say). Found wins, then fixed, then absent.
758 my $maxbuggy = 'absent';
759 for my $version (@sourceversions) {
760 my $buggy = buggy(bug => $param{bug},
762 found => $status{found_versions},
763 fixed => $status{fixed_versions},
764 version_cache => $version_cache,
765 package => $status{package},
767 if ($buggy eq 'found') {
770 } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
774 if ($maxbuggy eq 'absent') {
775 $status{"pending"} = 'absent';
776 } elsif ($maxbuggy eq 'fixed') {
777 $status{"pending"} = 'done';
781 if (length($status{done}) and
782 (not @sourceversions or not @{$status{fixed_versions}})) {
783 $status{"pending"} = 'done';
798 Returns the output of Debbugs::Versions::buggy for a particular
799 package, version and found/fixed set. Automatically turns found, fixed
800 and version into source/version strings.
802 Caching can be had by using the version_cache, but no attempt to check
803 to see if the on disk information is more recent than the cache is
804 made. [This will need to be fixed for long-lived processes.]
809 my %param = validate_with(params => \@_,
810 spec => {bug => {type => SCALAR,
813 found => {type => ARRAYREF,
816 fixed => {type => ARRAYREF,
819 version_cache => {type => HASHREF,
822 package => {type => SCALAR,
824 version => {type => SCALAR,
828 my @found = @{$param{found}};
829 my @fixed = @{$param{fixed}};
830 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
831 # We have non-source version versions
832 @found = makesourceversions($param{package},undef,
835 @fixed = makesourceversions($param{package},undef,
839 if ($param{version} !~ m{/}) {
840 $param{version} = makesourceversions($param{package},undef,
844 # Figure out which source packages we need
846 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
847 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
848 @sources{map {m{(.+)/}; $1} $param{version}} = 1;
850 if (not defined $param{version_cache} or
851 not exists $param{version_cache}{join(',',sort keys %sources)}) {
852 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
853 foreach my $source (keys %sources) {
854 my $srchash = substr $source, 0, 1;
855 my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
856 $version->load($version_fh);
858 if (defined $param{version_cache}) {
859 $param{version_cache}{join(',',sort keys %sources)} = $version;
863 $version = $param{version_cache}{join(',',sort keys %sources)};
865 return $version->buggy($param{version},\@found,\@fixed);