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;
42 $DEBUG = 0 unless defined $DEBUG;
45 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable)],
46 read => [qw(readbug read_bug lockreadbug)],
47 write => [qw(writebug makestatus unlockwritebug)],
48 versions => [qw(addfoundversion addfixedversion),
52 Exporter::export_ok_tags(qw(status read write versions));
53 $EXPORT_TAGS{all} = [@EXPORT_OK];
59 readbug($bug_num,$location)
62 Reads a summary file from the archive given a bug number and a bug
63 location. Valid locations are those understood by L</getbugcomponent>
68 my %fields = (originator => 'submitter',
71 msgid => 'message-id',
72 'package' => 'package',
75 forwarded => 'forwarded-to',
76 mergedwith => 'merged-with',
77 severity => 'severity',
79 found_versions => 'found-in',
80 found_date => 'found-date',
81 fixed_versions => 'fixed-in',
82 fixed_date => 'fixed-date',
84 blockedby => 'blocked-by',
87 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
88 my @rfc1522_fields = qw(originator subject done forwarded owner);
91 return read_bug(bug => $_[0],
92 (@_ > 1)?(location => $_[1]):()
98 read_bug(bug => $bug_num,
99 location => 'archive',
101 read_bug(summary => 'path/to/bugnum.summary');
104 A more complete function than readbug; it enables you to pass a full
105 path to the summary file instead of the bug number and/or location.
111 =item bug -- the bug number
113 =item location -- optional location which is passed to getbugcomponent
115 =item summary -- complete path to the .summary file which will be read
119 One of C<bug> or C<summary> must be passed. This function will return
120 undef on failure, and will die if improper arguments are passed.
128 my %param = validate_with(params => \@_,
129 spec => {bug => {type => SCALAR,
133 location => {type => SCALAR,
136 summary => {type => SCALAR,
141 die "One of bug or summary must be passed to read_bug"
142 if not exists $param{bug} and not exists $param{summary};
144 if (not defined $param{summary}) {
145 my ($lref, $location) = @param{qw(bug location)};
146 if (not defined $location) {
147 $location = getbuglocation($lref,'summary');
148 return undef if not defined $location;
150 $status = getbugcomponent($lref, 'summary', $location);
151 return undef unless defined $status;
154 $status = $param{summary};
156 my $status_fh = new IO::File $status, 'r' or
157 warn "Unable to open $status for reading: $!" and return undef;
164 while (<$status_fh>) {
167 $version = $1 if /^Format-Version: ([0-9]+)/i;
170 # Version 3 is the latest format version currently supported.
171 return undef if $version > 3;
173 my %namemap = reverse %fields;
174 for my $line (@lines) {
175 if ($line =~ /(\S+?): (.*)/) {
176 my ($name, $value) = (lc $1, $2);
177 $data{$namemap{$name}} = $value if exists $namemap{$name};
180 for my $field (keys %fields) {
181 $data{$field} = '' unless exists $data{$field};
184 $data{severity} = $config{default_severity} if $data{severity} eq '';
185 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
186 $data{$field} = [split ' ', $data{$field}];
188 for my $field (qw(found fixed)) {
189 @{$data{$field}}{@{$data{"${field}_versions"}}} =
190 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
191 @{$data{"${field}_date"}});
195 for my $field (@rfc1522_fields) {
196 $data{$field} = decode_rfc1522($data{$field});
205 lockreadbug($bug_num,$location)
207 Performs a filelock, then reads the bug; the bug is unlocked if the
208 return is undefined, otherwise, you need to call unfilelock or
211 See readbug above for information on what this returns
216 my ($lref, $location) = @_;
217 &filelock("lock/$lref");
218 my $data = read_bug(bug => $lref, location => $location);
219 &unfilelock unless defined $data;
223 my @v1fieldorder = qw(originator date subject msgid package
224 keywords done forwarded mergedwith severity);
228 my $content = makestatus($status,$version)
229 my $content = makestatus($status);
231 Creates the content for a status file based on the $status hashref
234 Really only useful for writebug
236 Currently defaults to version 2 (non-encoded rfc1522 names) but will
237 eventually default to version 3. If you care, you should specify a
243 my ($data,$version) = @_;
244 $version = 2 unless defined $version;
248 my %newdata = %$data;
249 for my $field (qw(found fixed)) {
250 if (exists $newdata{$field}) {
251 $newdata{"${field}_date"} =
252 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
256 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
257 $newdata{$field} = [split ' ', $newdata{$field}];
261 for my $field (@rfc1522_fields) {
262 $newdata{$field} = encode_rfc1522($newdata{$field});
267 for my $field (@v1fieldorder) {
268 if (exists $newdata{$field}) {
269 $contents .= "$newdata{$field}\n";
274 } elsif ($version == 2 or $version == 3) {
275 # Version 2 or 3. Add a file format version number for the sake of
276 # further extensibility in the future.
277 $contents .= "Format-Version: $version\n";
278 for my $field (keys %fields) {
279 if (exists $newdata{$field} and $newdata{$field} ne '') {
280 # Output field names in proper case, e.g. 'Merged-With'.
281 my $properfield = $fields{$field};
282 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
283 $contents .= "$properfield: $newdata{$field}\n";
293 writebug($bug_num,$status,$location,$minversion,$disablebughook)
295 Writes the bug status and summary files out.
297 Skips writting out a status file if minversion is 2
299 Does not call bughook if disablebughook is true.
304 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
307 my %outputs = (1 => 'status', 2 => 'summary');
308 for my $version (keys %outputs) {
309 next if defined $minversion and $version < $minversion;
310 my $status = getbugcomponent($ref, $outputs{$version}, $location);
311 &quit("can't find location for $ref") unless defined $status;
312 open(S,"> $status.new") || &quit("opening $status.new: $!");
313 print(S makestatus($data, $version)) ||
314 &quit("writing $status.new: $!");
315 close(S) || &quit("closing $status.new: $!");
321 rename("$status.new",$status) || &quit("installing new $status: $!");
324 # $disablebughook is a bit of a hack to let format migration scripts use
325 # this function rather than having to duplicate it themselves.
326 &bughook($change,$ref,$data) unless $disablebughook;
329 =head2 unlockwritebug
331 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
333 Writes a bug, then calls unfilelock; see writebug for what these
345 The following functions are exported with the :versions tag
347 =head2 addfoundversions
349 addfoundversions($status,$package,$version,$isbinary);
356 sub addfoundversions {
360 my $isbinary = shift;
361 return unless defined $version;
362 undef $package if $package =~ m[(?:\s|/)];
363 my $source = $package;
365 if (defined $package and $isbinary) {
366 my @srcinfo = binarytosource($package, $version, undef);
368 # We know the source package(s). Use a fully-qualified version.
369 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
372 # Otherwise, an unqualified version will have to do.
376 # Strip off various kinds of brain-damage.
378 $version =~ s/ *\(.*\)//;
379 $version =~ s/ +[A-Za-z].*//;
381 foreach my $ver (split /[,\s]+/, $version) {
382 my $sver = defined($source) ? "$source/$ver" : '';
383 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
384 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
386 @{$data->{fixed_versions}} =
387 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
391 sub removefoundversions {
395 my $isbinary = shift;
396 return unless defined $version;
397 undef $package if $package =~ m[(?:\s|/)];
398 my $source = $package;
400 if (defined $package and $isbinary) {
401 my @srcinfo = binarytosource($package, $version, undef);
403 # We know the source package(s). Use a fully-qualified version.
404 removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
407 # Otherwise, an unqualified version will have to do.
411 foreach my $ver (split /[,\s]+/, $version) {
412 my $sver = defined($source) ? "$source/$ver" : '';
413 @{$data->{found_versions}} =
414 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
418 sub addfixedversions {
422 my $isbinary = shift;
423 return unless defined $version;
424 undef $package if $package =~ m[(?:\s|/)];
425 my $source = $package;
427 if (defined $package and $isbinary) {
428 my @srcinfo = binarytosource($package, $version, undef);
430 # We know the source package(s). Use a fully-qualified version.
431 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
434 # Otherwise, an unqualified version will have to do.
438 # Strip off various kinds of brain-damage.
440 $version =~ s/ *\(.*\)//;
441 $version =~ s/ +[A-Za-z].*//;
443 foreach my $ver (split /[,\s]+/, $version) {
444 my $sver = defined($source) ? "$source/$ver" : '';
445 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
446 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
448 @{$data->{found_versions}} =
449 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
453 sub removefixedversions {
457 my $isbinary = shift;
458 return unless defined $version;
459 undef $package if $package =~ m[(?:\s|/)];
460 my $source = $package;
462 if (defined $package and $isbinary) {
463 my @srcinfo = binarytosource($package, $version, undef);
465 # We know the source package(s). Use a fully-qualified version.
466 removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
469 # Otherwise, an unqualified version will have to do.
473 foreach my $ver (split /[,\s]+/, $version) {
474 my $sver = defined($source) ? "$source/$ver" : '';
475 @{$data->{fixed_versions}} =
476 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
486 Split a package string from the status file into a list of package names.
492 return unless defined $pkgs;
493 return map lc, split /[ \t?,()]+/, $pkgs;
497 =head2 bug_archiveable
499 bug_archiveable(bug => $bug_num);
505 =item bug -- bug number (required)
507 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
509 =item version -- Debbugs::Version information (optional)
511 =item days_until -- return days until the bug can be archived
515 Returns 1 if the bug can be archived
516 Returns 0 if the bug cannot be archived
518 If days_until is true, returns the number of days until the bug can be
519 archived, -1 if it cannot be archived. 0 means that the bug can be
520 archived the next time the archiver runs.
522 Returns undef on failure.
526 # This will eventually need to be fixed before we start using mod_perl
527 my $version_cache = {};
529 my %param = validate_with(params => \@_,
530 spec => {bug => {type => SCALAR,
533 status => {type => HASHREF,
536 version => {type => HASHREF,
539 days_until => {type => BOOLEAN,
544 # This is what we return if the bug cannot be archived.
545 my $cannot_archive = $param{days_until}?-1:0;
546 # read the status information
547 my $status = $param{status};
548 if (not exists $param{status} or not defined $status) {
549 $status = read_bug(bug=>$param{bug});
550 return undef if not defined $status;
552 # Bugs can be archived if they are
554 return $cannot_archive if not defined $status->{done} or not length $status->{done};
555 # If we just are checking if the bug can be archived, we'll not even bother
556 # checking the versioning information if the bug has been -done for less than 28 days.
557 if (not $param{days_until} and $config{remove_age} >
558 -M getbugcomponent($param{ref},'log')
560 return $cannot_archive;
562 # At this point, we have to get the versioning information for this bug.
564 # We examine the set of distribution tags. If a bug has no distribution
565 # tags set, we assume a default set, otherwise we use the tags the bug
568 @dist_tags{@{$config{removal_distribution_tags}}} =
569 (1) x @{$config{removal_distribution_tags}};
571 @dists{@{$config{removal_default_distribution_tags}}} =
572 (1) x @{$config{removal_default_distribution_tags}};
573 for my $tag (split ' ', $status->{tags}) {
574 next unless $dist_tags{$tag};
578 for my $dist (keys %dists){
580 if (defined $param{version}) {
581 @versions = ($param{version});
582 } elsif (defined $param{dist}) {
583 @versions = getversions($status->{package},
588 # TODO: This should probably be handled further out for efficiency and
589 # for more ease of distinguishing between pkg= and src= queries.
590 my @sourceversions = makesourceversions($status->{package},
593 @source_versions{@sourceversions} = (1) x @sourceversions;
595 if ('found' eq max_buggy(bug => $param{bug},
596 sourceversions => [keys %source_versions],
597 found => $status->{found_versions},
598 fixed => $status->{fixed_versions},
599 version_cache => $version_cache,
600 package => $status->{package},
602 return $cannot_archive;
604 # 6. at least 28 days have passed since the last action has occured or the bug was closed
605 # XXX We still need some more work here before we actually can archive;
606 # we really need to track when a bug was closed in a version.
607 my $age = ceil($config{remove_age} - -M getbugcomponent($param{bug},'log'));
609 return $param{days_until}?$age:0;
612 return $param{days_until}?0:1;
617 =head2 get_bug_status
619 my $status = get_bug_status(bug => $nnn);
621 my $status = get_bug_status($bug_num)
627 =item bug -- scalar bug number
629 =item status -- optional hashref of bug status as returned by readbug
630 (can be passed to avoid rereading the bug information)
632 =item bug_index -- optional tied index of bug status infomration;
633 currently not correctly implemented.
635 =item version -- optional version to check package status at
637 =item dist -- optional distribution to check package status at
639 =item arch -- optional architecture to check package status at
641 =item usertags -- optional hashref of usertags
643 =item sourceversion -- optional arrayref of source/version; overrides
644 dist, arch, and version. [The entries in this array must be in the
645 "source/version" format.] Eventually this can be used to for caching.
649 Note: Currently the version information is cached; this needs to be
650 changed before using this function in long lived programs.
658 my %param = validate_with(params => \@_,
659 spec => {bug => {type => SCALAR,
662 status => {type => HASHREF,
665 bug_index => {type => OBJECT,
668 version => {type => SCALAR,
671 dist => {type => SCALAR,
674 arch => {type => SCALAR,
677 usertags => {type => HASHREF,
680 sourceversions => {type => ARRAYREF,
687 if (defined $param{bug_index} and
688 exists $param{bug_index}{$param{bug}}) {
689 %status = %{ $param{bug_index}{$param{bug}} };
690 $status{pending} = $status{ status };
691 $status{id} = $param{bug};
694 if (defined $param{status}) {
695 %status = %{$param{status}};
698 my $location = getbuglocation($param{bug}, 'summary');
699 return {} if not length $location;
700 %status = %{ readbug( $param{bug}, $location ) };
702 $status{id} = $param{bug};
704 if (defined $param{usertags}{$param{bug}}) {
705 $status{keywords} = "" unless defined $status{keywords};
706 $status{keywords} .= " " unless $status{keywords} eq "";
707 $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}});
709 $status{tags} = $status{keywords};
710 my %tags = map { $_ => 1 } split ' ', $status{tags};
712 $status{"package"} =~ s/\s*$//;
713 $status{"package"} = 'unknown' if ($status{"package"} eq '');
714 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
716 $status{"pending"} = 'pending';
717 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
718 $status{"pending"} = 'pending-fixed' if ($tags{pending});
719 $status{"pending"} = 'fixed' if ($tags{fixed});
722 if (not exists $param{sourceversions}) {
724 if (defined $param{version}) {
725 @versions = ($param{version});
726 } elsif (defined $param{dist}) {
727 @versions = getversions($status{package}, $param{dist}, $param{arch});
730 # TODO: This should probably be handled further out for efficiency and
731 # for more ease of distinguishing between pkg= and src= queries.
732 @sourceversions = makesourceversions($status{package},
737 @sourceversions = @{$param{sourceversions}};
739 if (@sourceversions) {
740 my $maxbuggy = max_buggy(bug => $param{bug},
741 sourceversions => \@sourceversions,
742 found => $status{found_versions},
743 fixed => $status{fixed_versions}.
744 package => $status{package},
745 version_cache => $version_cache,
747 if ($maxbuggy eq 'absent') {
748 $status{pending} = 'absent';
750 elsif ($maxbuggy eq 'fixed' ) {
751 $status{pending} = 'done';
754 if (length($status{done}) and
755 (not @sourceversions or not @{$status{fixed_versions}})) {
756 $status{"pending"} = 'done';
771 =item bug -- scalar bug number
773 =item sourceversion -- optional arrayref of source/version; overrides
774 dist, arch, and version. [The entries in this array must be in the
775 "source/version" format.] Eventually this can be used to for caching.
779 Note: Currently the version information is cached; this needs to be
780 changed before using this function in long lived programs.
785 my %param = validate_with(params => \@_,
786 spec => {bug => {type => SCALAR,
789 sourceversions => {type => ARRAYREF,
792 found => {type => ARRAYREF,
795 fixed => {type => ARRAYREF,
798 package => {type => SCALAR,
800 version_cache => {type => HASHREF,
805 # Resolve bugginess states (we might be looking at multiple
806 # architectures, say). Found wins, then fixed, then absent.
807 my $maxbuggy = 'absent';
808 for my $version (@{$param{sourceversions}}) {
809 my $buggy = buggy(bug => $param{bug},
811 found => $param{found},
812 fixed => $param{fixed},
813 version_cache => $param{version_cache},
814 package => $param{package},
816 if ($buggy eq 'found') {
818 } elsif ($buggy eq 'fixed') {
835 Returns the output of Debbugs::Versions::buggy for a particular
836 package, version and found/fixed set. Automatically turns found, fixed
837 and version into source/version strings.
839 Caching can be had by using the version_cache, but no attempt to check
840 to see if the on disk information is more recent than the cache is
841 made. [This will need to be fixed for long-lived processes.]
846 my %param = validate_with(params => \@_,
847 spec => {bug => {type => SCALAR,
850 found => {type => ARRAYREF,
853 fixed => {type => ARRAYREF,
856 version_cache => {type => HASHREF,
859 package => {type => SCALAR,
861 version => {type => SCALAR,
865 my @found = @{$param{found}};
866 my @fixed = @{$param{fixed}};
867 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
868 # We have non-source version versions
869 @found = makesourceversions($param{package},undef,
872 @fixed = makesourceversions($param{package},undef,
876 if ($param{version} !~ m{/}) {
877 $param{version} = makesourceversions($param{package},undef,
881 # Figure out which source packages we need
883 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
884 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
885 @sources{map {m{(.+)/}; $1} $param{version}} = 1;
887 if (not defined $param{version_cache} or
888 not exists $param{version_cache}{join(',',sort keys %sources)}) {
889 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
890 foreach my $source (keys %sources) {
891 my $srchash = substr $source, 0, 1;
892 my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r';
893 $version->load($version_fh);
895 if (defined $param{version_cache}) {
896 $param{version_cache}{join(',',sort keys %sources)} = $version;
900 $version = $param{version_cache}{join(',',sort keys %sources)};
902 return $version->buggy($param{version},\@found,\@fixed);
905 =head1 PRIVATE FUNCTIONS
909 sub update_realtime {
910 my ($file, $bug, $new) = @_;
912 # update realtime index.db
914 open(IDXDB, "<$file") or die "Couldn't open $file";
915 open(IDXNEW, ">$file.new");
919 while($line = <IDXDB>) {
920 @line = split /\s/, $line;
921 last if ($line[1] >= $bug);
926 if ($new eq "NOCHANGE") {
927 print IDXNEW $line if ($line ne "" && $line[1] == $bug);
928 } elsif ($new eq "REMOVE") {
933 if ($line ne "" && $line[1] > $bug) {
938 print IDXNEW while(<IDXDB>);
943 rename("$file.new", $file);
948 sub bughook_archive {
950 &filelock("debbugs.trace.lock");
951 &appendfile("debbugs.trace","archive $ref\n");
952 my $line = update_realtime(
953 "$config{spool_dir}/index.db.realtime",
956 update_realtime("$config{spool_dir}/index.archive.realtime",
962 my ( $type, $ref, $data ) = @_;
963 &filelock("debbugs.trace.lock");
965 &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
967 my $whendone = "open";
968 my $severity = $config{default_severity};
969 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
972 $whendone = "forwarded" if length $data->{forwarded};
973 $whendone = "done" if length $data->{done};
974 $severity = $data->{severity} if length $data->{severity};
976 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
977 $pkglist, $ref, $data->{date}, $whendone,
978 $data->{originator}, $severity, $data->{keywords};
980 update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);