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.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Status;
14 Debbugs::Status -- Routines for dealing with summary and status files
23 This module is a replacement for the parts of errorlib.pl which write
24 and read status and summary files.
26 It also contains generic routines for returning information about the
27 status of a particular bug
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(:util :lock :quit :misc);
41 use Debbugs::Config qw(:config);
42 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
43 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binarytosource);
44 use Debbugs::Versions;
45 use Debbugs::Versions::Dpkg;
48 use List::Util qw(min max);
53 $DEBUG = 0 unless defined $DEBUG;
56 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
57 qw(isstrongseverity bug_presence),
59 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
60 qw(lock_read_all_merged_bugs),
62 write => [qw(writebug makestatus unlockwritebug)],
63 versions => [qw(addfoundversions addfixedversions),
64 qw(removefoundversions removefixedversions)
66 hook => [qw(bughook bughook_archive)],
67 fields => [qw(%fields)],
70 Exporter::export_ok_tags(qw(status read write versions hook fields));
71 $EXPORT_TAGS{all} = [@EXPORT_OK];
77 readbug($bug_num,$location)
80 Reads a summary file from the archive given a bug number and a bug
81 location. Valid locations are those understood by L</getbugcomponent>
85 # these probably shouldn't be imported by most people, but
86 # Debbugs::Control needs them, so they're now exportable
87 our %fields = (originator => 'submitter',
90 msgid => 'message-id',
91 'package' => 'package',
94 forwarded => 'forwarded-to',
95 mergedwith => 'merged-with',
96 severity => 'severity',
98 found_versions => 'found-in',
99 found_date => 'found-date',
100 fixed_versions => 'fixed-in',
101 fixed_date => 'fixed-date',
103 blockedby => 'blocked-by',
104 unarchived => 'unarchived',
105 summary => 'summary',
106 affects => 'affects',
109 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
110 my @rfc1522_fields = qw(originator subject done forwarded owner);
113 return read_bug(bug => $_[0],
114 (@_ > 1)?(location => $_[1]):()
120 read_bug(bug => $bug_num,
121 location => 'archive',
123 read_bug(summary => 'path/to/bugnum.summary');
126 A more complete function than readbug; it enables you to pass a full
127 path to the summary file instead of the bug number and/or location.
133 =item bug -- the bug number
135 =item location -- optional location which is passed to getbugcomponent
137 =item summary -- complete path to the .summary file which will be read
139 =item lock -- whether to obtain a lock for the bug to prevent
140 something modifying it while the bug has been read. You B<must> call
141 C<unfilelock();> if something not undef is returned from read_bug.
145 One of C<bug> or C<summary> must be passed. This function will return
146 undef on failure, and will die if improper arguments are passed.
154 my %param = validate_with(params => \@_,
155 spec => {bug => {type => SCALAR,
159 # negative bugnumbers
162 location => {type => SCALAR|UNDEF,
165 summary => {type => SCALAR,
168 lock => {type => BOOLEAN,
173 die "One of bug or summary must be passed to read_bug"
174 if not exists $param{bug} and not exists $param{summary};
178 if (not defined $param{summary}) {
180 ($lref,$location) = @param{qw(bug location)};
181 if (not defined $location) {
182 $location = getbuglocation($lref,'summary');
183 return undef if not defined $location;
185 $status = getbugcomponent($lref, 'summary', $location);
186 $log = getbugcomponent($lref, 'log' , $location);
187 return undef unless defined $status;
188 return undef if not -e $status;
191 $status = $param{summary};
193 $log =~ s/\.summary$/.log/;
194 ($location) = $status =~ m/(db-h|db|archive)/;
197 filelock("$config{spool_dir}/lock/$param{bug}");
199 my $status_fh = IO::File->new($status, 'r');
200 if (not defined $status_fh) {
201 warn "Unable to open $status for reading: $!";
213 while (<$status_fh>) {
216 $version = $1 if /^Format-Version: ([0-9]+)/i;
219 # Version 3 is the latest format version currently supported.
221 warn "Unsupported status version '$version'";
228 my %namemap = reverse %fields;
229 for my $line (@lines) {
230 if ($line =~ /(\S+?): (.*)/) {
231 my ($name, $value) = (lc $1, $2);
232 $data{$namemap{$name}} = $value if exists $namemap{$name};
235 for my $field (keys %fields) {
236 $data{$field} = '' unless exists $data{$field};
239 $data{severity} = $config{default_severity} if $data{severity} eq '';
240 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
241 $data{$field} = [split ' ', $data{$field}];
243 for my $field (qw(found fixed)) {
244 # create the found/fixed hashes which indicate when a
245 # particular version was marked found or marked fixed.
246 @{$data{$field}}{@{$data{"${field}_versions"}}} =
247 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
248 @{$data{"${field}_date"}});
252 for my $field (@rfc1522_fields) {
253 $data{$field} = decode_rfc1522($data{$field});
256 my $status_modified = (stat($status))[9];
257 # Add log last modified time
258 $data{log_modified} = (stat($log))[9];
259 $data{last_modified} = max($status_modified,$data{log_modified});
260 $data{location} = $location;
261 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
262 $data{bug_num} = $param{bug};
269 lockreadbug($bug_num,$location)
271 Performs a filelock, then reads the bug; the bug is unlocked if the
272 return is undefined, otherwise, you need to call unfilelock or
275 See readbug above for information on what this returns
280 my ($lref, $location) = @_;
281 return read_bug(bug => $lref, location => $location, lock => 1);
284 =head2 lockreadbugmerge
286 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
288 Performs a filelock, then reads the bug. If the bug is merged, locks
289 the merge lock. Returns a list of the number of locks and the bug
294 sub lockreadbugmerge {
295 my ($bug_num,$location) = @_;
296 my $data = lockreadbug(@_);
297 if (not defined $data) {
300 if (not length $data->{mergedwith}) {
304 filelock("$config{spool_dir}/lock/merge");
305 $data = lockreadbug(@_);
306 if (not defined $data) {
313 =head2 lock_read_all_merged_bugs
315 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
317 Performs a filelock, then reads the bug passed. If the bug is merged,
318 locks the merge lock, then reads and locks all of the other merged
319 bugs. Returns a list of the number of locks and the bug data for all
322 Will also return undef if any of the merged bugs failed to be read,
323 even if all of the others were read properly.
327 sub lock_read_all_merged_bugs {
328 my ($bug_num,$location) = @_;
330 my @data = (lockreadbug(@_));
331 if (not @data or not defined $data[0]) {
335 if (not length $data[0]->{mergedwith}) {
336 return ($locks,@data);
340 filelock("$config{spool_dir}/lock/merge");
342 @data = (lockreadbug(@_));
343 if (not @data or not defined $data[0]) {
344 unfilelock(); #for merge lock above
349 my @bugs = split / /, $data[0]->{mergedwith};
350 for my $bug (@bugs) {
352 if ($bug ne $bug_num) {
353 $newdata = lockreadbug($bug,$location);
354 if (not defined $newdata) {
359 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
365 # perform a sanity check to make sure that the merged bugs are
366 # all merged with eachother
367 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
368 if ($newdata->{mergedwith} ne $expectmerge) {
372 die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
375 return ($locks,@data);
379 my @v1fieldorder = qw(originator date subject msgid package
380 keywords done forwarded mergedwith severity);
384 my $content = makestatus($status,$version)
385 my $content = makestatus($status);
387 Creates the content for a status file based on the $status hashref
390 Really only useful for writebug
392 Currently defaults to version 2 (non-encoded rfc1522 names) but will
393 eventually default to version 3. If you care, you should specify a
399 my ($data,$version) = @_;
400 $version = 2 unless defined $version;
404 my %newdata = %$data;
405 for my $field (qw(found fixed)) {
406 if (exists $newdata{$field}) {
407 $newdata{"${field}_date"} =
408 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
412 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
413 $newdata{$field} = join ' ', @{$newdata{$field}||[]};
417 for my $field (@rfc1522_fields) {
418 $newdata{$field} = encode_rfc1522($newdata{$field});
423 for my $field (@v1fieldorder) {
424 if (exists $newdata{$field} and defined $newdata{$field}) {
425 $contents .= "$newdata{$field}\n";
430 } elsif ($version == 2 or $version == 3) {
431 # Version 2 or 3. Add a file format version number for the sake of
432 # further extensibility in the future.
433 $contents .= "Format-Version: $version\n";
434 for my $field (keys %fields) {
435 if (exists $newdata{$field} and defined $newdata{$field}
436 and $newdata{$field} ne '') {
437 # Output field names in proper case, e.g. 'Merged-With'.
438 my $properfield = $fields{$field};
439 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
440 $contents .= "$properfield: $newdata{$field}\n";
450 writebug($bug_num,$status,$location,$minversion,$disablebughook)
452 Writes the bug status and summary files out.
454 Skips writting out a status file if minversion is 2
456 Does not call bughook if disablebughook is true.
461 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
464 my %outputs = (1 => 'status', 2 => 'summary');
465 for my $version (keys %outputs) {
466 next if defined $minversion and $version < $minversion;
467 my $status = getbugcomponent($ref, $outputs{$version}, $location);
468 die "can't find location for $ref" unless defined $status;
469 open(S,"> $status.new") || die "opening $status.new: $!";
470 print(S makestatus($data, $version)) ||
471 die "writing $status.new: $!";
472 close(S) || die "closing $status.new: $!";
478 rename("$status.new",$status) || die "installing new $status: $!";
481 # $disablebughook is a bit of a hack to let format migration scripts use
482 # this function rather than having to duplicate it themselves.
483 &bughook($change,$ref,$data) unless $disablebughook;
486 =head2 unlockwritebug
488 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
490 Writes a bug, then calls unfilelock; see writebug for what these
502 The following functions are exported with the :versions tag
504 =head2 addfoundversions
506 addfoundversions($status,$package,$version,$isbinary);
513 sub addfoundversions {
517 my $isbinary = shift;
518 return unless defined $version;
519 undef $package if $package =~ m[(?:\s|/)];
520 my $source = $package;
522 if (defined $package and $isbinary) {
523 my @srcinfo = binarytosource($package, $version, undef);
525 # We know the source package(s). Use a fully-qualified version.
526 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
529 # Otherwise, an unqualified version will have to do.
533 # Strip off various kinds of brain-damage.
535 $version =~ s/ *\(.*\)//;
536 $version =~ s/ +[A-Za-z].*//;
538 foreach my $ver (split /[,\s]+/, $version) {
539 my $sver = defined($source) ? "$source/$ver" : '';
540 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
541 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
543 @{$data->{fixed_versions}} =
544 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
548 =head2 removefoundversions
550 removefoundversions($data,$package,$versiontoremove)
552 Removes found versions from $data
554 If a version is fully qualified (contains /) only versions matching
555 exactly are removed. Otherwise, all versions matching the version
558 Currently $package and $isbinary are entirely ignored, but accepted
559 for backwards compatibilty.
563 sub removefoundversions {
567 my $isbinary = shift;
568 return unless defined $version;
570 foreach my $ver (split /[,\s]+/, $version) {
572 # fully qualified version
573 @{$data->{found_versions}} =
575 @{$data->{found_versions}};
578 # non qualified version; delete all matchers
579 @{$data->{found_versions}} =
580 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
581 @{$data->{found_versions}};
587 sub addfixedversions {
591 my $isbinary = shift;
592 return unless defined $version;
593 undef $package if defined $package and $package =~ m[(?:\s|/)];
594 my $source = $package;
596 if (defined $package and $isbinary) {
597 my @srcinfo = binarytosource($package, $version, undef);
599 # We know the source package(s). Use a fully-qualified version.
600 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
603 # Otherwise, an unqualified version will have to do.
607 # Strip off various kinds of brain-damage.
609 $version =~ s/ *\(.*\)//;
610 $version =~ s/ +[A-Za-z].*//;
612 foreach my $ver (split /[,\s]+/, $version) {
613 my $sver = defined($source) ? "$source/$ver" : '';
614 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
615 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
617 @{$data->{found_versions}} =
618 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
622 sub removefixedversions {
626 my $isbinary = shift;
627 return unless defined $version;
629 foreach my $ver (split /[,\s]+/, $version) {
631 # fully qualified version
632 @{$data->{fixed_versions}} =
634 @{$data->{fixed_versions}};
637 # non qualified version; delete all matchers
638 @{$data->{fixed_versions}} =
639 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
640 @{$data->{fixed_versions}};
651 Split a package string from the status file into a list of package names.
657 return unless defined $pkgs;
658 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
662 =head2 bug_archiveable
664 bug_archiveable(bug => $bug_num);
670 =item bug -- bug number (required)
672 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
674 =item version -- Debbugs::Version information (optional)
676 =item days_until -- return days until the bug can be archived
680 Returns 1 if the bug can be archived
681 Returns 0 if the bug cannot be archived
683 If days_until is true, returns the number of days until the bug can be
684 archived, -1 if it cannot be archived. 0 means that the bug can be
685 archived the next time the archiver runs.
687 Returns undef on failure.
691 # This will eventually need to be fixed before we start using mod_perl
692 our $version_cache = {};
694 my %param = validate_with(params => \@_,
695 spec => {bug => {type => SCALAR,
698 status => {type => HASHREF,
701 days_until => {type => BOOLEAN,
704 ignore_time => {type => BOOLEAN,
709 # This is what we return if the bug cannot be archived.
710 my $cannot_archive = $param{days_until}?-1:0;
711 # read the status information
712 my $status = $param{status};
713 if (not exists $param{status} or not defined $status) {
714 $status = read_bug(bug=>$param{bug});
715 if (not defined $status) {
716 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
720 # Bugs can be archived if they are
722 if (not defined $status->{done} or not length $status->{done}) {
723 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
724 return $cannot_archive
726 # Check to make sure that the bug has none of the unremovable tags set
727 if (@{$config{removal_unremovable_tags}}) {
728 for my $tag (split ' ', ($status->{tags}||'')) {
729 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
730 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
731 return $cannot_archive;
736 # If we just are checking if the bug can be archived, we'll not even bother
737 # checking the versioning information if the bug has been -done for less than 28 days.
738 my $log_file = getbugcomponent($param{bug},'log');
739 if (not defined $log_file) {
740 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
741 return $cannot_archive;
743 my $max_log_age = max(map {$config{remove_age} - -M $_}
744 $log_file, map {my $log = getbugcomponent($_,'log');
745 defined $log ? ($log) : ();
747 split / /, $status->{mergedwith}
749 if (not $param{days_until} and not $param{ignore_time}
752 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
753 return $cannot_archive;
755 # At this point, we have to get the versioning information for this bug.
756 # We examine the set of distribution tags. If a bug has no distribution
757 # tags set, we assume a default set, otherwise we use the tags the bug
760 # In cases where we are assuming a default set, if the severity
761 # is strong, we use the strong severity default; otherwise, we
762 # use the normal default.
764 # There must be fixed_versions for us to look at the versioning
766 my $min_fixed_time = time;
767 my $min_archive_days = 0;
768 if (@{$status->{fixed_versions}}) {
770 @dist_tags{@{$config{removal_distribution_tags}}} =
771 (1) x @{$config{removal_distribution_tags}};
773 for my $tag (split ' ', ($status->{tags}||'')) {
774 next unless exists $config{distribution_aliases}{$tag};
775 next unless $dist_tags{$config{distribution_aliases}{$tag}};
776 $dists{$config{distribution_aliases}{$tag}} = 1;
778 if (not keys %dists) {
779 if (isstrongseverity($status->{severity})) {
780 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
781 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
784 @dists{@{$config{removal_default_distribution_tags}}} =
785 (1) x @{$config{removal_default_distribution_tags}};
789 my @sourceversions = get_versions(package => $status->{package},
790 dist => [keys %dists],
793 @source_versions{@sourceversions} = (1) x @sourceversions;
794 # If the bug has not been fixed in the versions actually
795 # distributed, then it cannot be archived.
796 if ('found' eq max_buggy(bug => $param{bug},
797 sourceversions => [keys %source_versions],
798 found => $status->{found_versions},
799 fixed => $status->{fixed_versions},
800 version_cache => $version_cache,
801 package => $status->{package},
803 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
804 return $cannot_archive;
806 # Since the bug has at least been fixed in the architectures
807 # that matters, we check to see how long it has been fixed.
809 # If $param{ignore_time}, then we should ignore time.
810 if ($param{ignore_time}) {
811 return $param{days_until}?0:1;
814 # To do this, we order the times from most recent to oldest;
815 # when we come to the first found version, we stop.
816 # If we run out of versions, we only report the time of the
818 my %time_versions = get_versions(package => $status->{package},
819 dist => [keys %dists],
823 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
824 my $buggy = buggy(bug => $param{bug},
826 found => $status->{found_versions},
827 fixed => $status->{fixed_versions},
828 version_cache => $version_cache,
829 package => $status->{package},
831 last if $buggy eq 'found';
832 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
834 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
835 # if there are no versions in the archive at all, then
836 # we can archive if enough days have passed
839 # If $param{ignore_time}, then we should ignore time.
840 if ($param{ignore_time}) {
841 return $param{days_until}?0:1;
843 # 6. at least 28 days have passed since the last action has occured or the bug was closed
844 my $age = ceil($max_log_age);
845 if ($age > 0 or $min_archive_days > 0) {
846 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
847 return $param{days_until}?max($age,$min_archive_days):0;
850 return $param{days_until}?0:1;
855 =head2 get_bug_status
857 my $status = get_bug_status(bug => $nnn);
859 my $status = get_bug_status($bug_num)
865 =item bug -- scalar bug number
867 =item status -- optional hashref of bug status as returned by readbug
868 (can be passed to avoid rereading the bug information)
870 =item bug_index -- optional tied index of bug status infomration;
871 currently not correctly implemented.
873 =item version -- optional version(s) to check package status at
875 =item dist -- optional distribution(s) to check package status at
877 =item arch -- optional architecture(s) to check package status at
879 =item bugusertags -- optional hashref of bugusertags
881 =item sourceversion -- optional arrayref of source/version; overrides
882 dist, arch, and version. [The entries in this array must be in the
883 "source/version" format.] Eventually this can be used to for caching.
885 =item indicatesource -- if true, indicate which source packages this
886 bug could belong to (or does belong to in the case of bugs assigned to
887 a source package). Defaults to true.
891 Note: Currently the version information is cached; this needs to be
892 changed before using this function in long lived programs.
900 my %param = validate_with(params => \@_,
901 spec => {bug => {type => SCALAR,
904 status => {type => HASHREF,
907 bug_index => {type => OBJECT,
910 version => {type => SCALAR|ARRAYREF,
913 dist => {type => SCALAR|ARRAYREF,
916 arch => {type => SCALAR|ARRAYREF,
919 bugusertags => {type => HASHREF,
922 sourceversions => {type => ARRAYREF,
925 indicatesource => {type => BOOLEAN,
932 if (defined $param{bug_index} and
933 exists $param{bug_index}{$param{bug}}) {
934 %status = %{ $param{bug_index}{$param{bug}} };
935 $status{pending} = $status{ status };
936 $status{id} = $param{bug};
939 if (defined $param{status}) {
940 %status = %{$param{status}};
943 my $location = getbuglocation($param{bug}, 'summary');
944 return {} if not defined $location or not length $location;
945 %status = %{ readbug( $param{bug}, $location ) };
947 $status{id} = $param{bug};
949 if (defined $param{bugusertags}{$param{bug}}) {
950 $status{keywords} = "" unless defined $status{keywords};
951 $status{keywords} .= " " unless $status{keywords} eq "";
952 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
954 $status{tags} = $status{keywords};
955 my %tags = map { $_ => 1 } split ' ', $status{tags};
957 $status{package} = '' if not defined $status{package};
958 $status{"package"} =~ s/\s*$//;
959 # if we aren't supposed to indicate the source, we'll return
961 $status{source} = 'unknown';
962 if ($param{indicatesource}) {
963 my @packages = split /\s*,\s*/, $status{package};
965 for my $package (@packages) {
966 next if $package eq '';
967 if ($package =~ /^src\:$/) {
971 push @source, binarytosource($package);
975 $status{source} = join(', ',@source);
979 $status{"package"} = 'unknown' if ($status{"package"} eq '');
980 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
982 $status{"pending"} = 'pending';
983 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
984 $status{"pending"} = 'pending-fixed' if ($tags{pending});
985 $status{"pending"} = 'fixed' if ($tags{fixed});
988 my $presence = bug_presence(status => \%status,
989 map{(exists $param{$_})?($_,$param{$_}):()}
990 qw(bug sourceversions arch dist version found fixed package)
992 if (defined $presence) {
993 if ($presence eq 'fixed') {
994 $status{pending} = 'done';
996 elsif ($presence eq 'absent') {
997 $status{pending} = 'absent';
1005 my $precence = bug_presence(bug => nnn,
1009 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1010 is found, absent, fixed, or no information is available in the
1011 distribution (dist) and/or architecture (arch) specified.
1018 =item bug -- scalar bug number
1020 =item status -- optional hashref of bug status as returned by readbug
1021 (can be passed to avoid rereading the bug information)
1023 =item bug_index -- optional tied index of bug status infomration;
1024 currently not correctly implemented.
1026 =item version -- optional version to check package status at
1028 =item dist -- optional distribution to check package status at
1030 =item arch -- optional architecture to check package status at
1032 =item sourceversion -- optional arrayref of source/version; overrides
1033 dist, arch, and version. [The entries in this array must be in the
1034 "source/version" format.] Eventually this can be used to for caching.
1041 my %param = validate_with(params => \@_,
1042 spec => {bug => {type => SCALAR,
1045 status => {type => HASHREF,
1048 version => {type => SCALAR|ARRAYREF,
1051 dist => {type => SCALAR|ARRAYREF,
1054 arch => {type => SCALAR|ARRAYREF,
1057 sourceversions => {type => ARRAYREF,
1063 if (defined $param{status}) {
1064 %status = %{$param{status}};
1067 my $location = getbuglocation($param{bug}, 'summary');
1068 return {} if not length $location;
1069 %status = %{ readbug( $param{bug}, $location ) };
1073 my $pseudo_desc = getpseudodesc();
1074 if (not exists $param{sourceversions}) {
1076 # pseudopackages do not have source versions by definition.
1077 if (exists $pseudo_desc->{$status{package}}) {
1080 elsif (defined $param{version}) {
1081 foreach my $arch (make_list($param{arch})) {
1082 for my $package (split /\s*,\s*/, $status{package}) {
1083 my @temp = makesourceversions($package,
1085 make_list($param{version})
1087 @sourceversions{@temp} = (1) x @temp;
1090 } elsif (defined $param{dist}) {
1091 my %affects_distribution_tags;
1092 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1093 (1) x @{$config{affects_distribution_tags}};
1094 my $some_distributions_disallowed = 0;
1095 my %allowed_distributions;
1096 for my $tag (split ' ', ($status{tags}||'')) {
1097 if (exists $config{distribution_aliases}{$tag} and
1098 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1099 $some_distributions_disallowed = 1;
1100 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1102 elsif (exists $affects_distribution_tags{$tag}) {
1103 $some_distributions_disallowed = 1;
1104 $allowed_distributions{$tag} = 1;
1107 foreach my $arch (make_list(exists $param{arch}?$param{arch}:undef)) {
1108 for my $package (split /\s*,\s*/, $status{package}) {
1111 if ($package =~ /^src:(.+)$/) {
1115 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1116 # if some distributions are disallowed,
1117 # and this isn't an allowed
1118 # distribution, then we ignore this
1119 # distribution for the purposees of
1121 if ($some_distributions_disallowed and
1122 not exists $allowed_distributions{$dist}) {
1125 push @versions, get_versions(package => $package,
1127 ($source?(arch => 'source'):
1128 (defined $arch?(arch => $arch):())),
1131 next unless @versions;
1132 my @temp = make_source_versions(package => $package,
1134 versions => \@versions,
1136 @sourceversions{@temp} = (1) x @temp;
1141 # TODO: This should probably be handled further out for efficiency and
1142 # for more ease of distinguishing between pkg= and src= queries.
1143 # DLA: src= queries should just pass arch=source, and they'll be happy.
1144 @sourceversions = keys %sourceversions;
1147 @sourceversions = @{$param{sourceversions}};
1149 my $maxbuggy = 'undef';
1150 if (@sourceversions) {
1151 $maxbuggy = max_buggy(bug => $param{bug},
1152 sourceversions => \@sourceversions,
1153 found => $status{found_versions},
1154 fixed => $status{fixed_versions},
1155 package => $status{package},
1156 version_cache => $version_cache,
1159 elsif (defined $param{dist} and
1160 not exists $pseudo_desc->{$status{package}}) {
1163 if (length($status{done}) and
1164 (not @sourceversions or not @{$status{fixed_versions}})) {
1179 =item bug -- scalar bug number
1181 =item sourceversion -- optional arrayref of source/version; overrides
1182 dist, arch, and version. [The entries in this array must be in the
1183 "source/version" format.] Eventually this can be used to for caching.
1187 Note: Currently the version information is cached; this needs to be
1188 changed before using this function in long lived programs.
1193 my %param = validate_with(params => \@_,
1194 spec => {bug => {type => SCALAR,
1197 sourceversions => {type => ARRAYREF,
1200 found => {type => ARRAYREF,
1203 fixed => {type => ARRAYREF,
1206 package => {type => SCALAR,
1208 version_cache => {type => HASHREF,
1213 # Resolve bugginess states (we might be looking at multiple
1214 # architectures, say). Found wins, then fixed, then absent.
1215 my $maxbuggy = 'absent';
1216 for my $package (split /\s*,\s*/, $param{package}) {
1217 for my $version (@{$param{sourceversions}}) {
1218 my $buggy = buggy(bug => $param{bug},
1219 version => $version,
1220 found => $param{found},
1221 fixed => $param{fixed},
1222 version_cache => $param{version_cache},
1223 package => $package,
1225 if ($buggy eq 'found') {
1227 } elsif ($buggy eq 'fixed') {
1228 $maxbuggy = 'fixed';
1245 Returns the output of Debbugs::Versions::buggy for a particular
1246 package, version and found/fixed set. Automatically turns found, fixed
1247 and version into source/version strings.
1249 Caching can be had by using the version_cache, but no attempt to check
1250 to see if the on disk information is more recent than the cache is
1251 made. [This will need to be fixed for long-lived processes.]
1256 my %param = validate_with(params => \@_,
1257 spec => {bug => {type => SCALAR,
1260 found => {type => ARRAYREF,
1263 fixed => {type => ARRAYREF,
1266 version_cache => {type => HASHREF,
1269 package => {type => SCALAR,
1271 version => {type => SCALAR,
1275 my @found = @{$param{found}};
1276 my @fixed = @{$param{fixed}};
1277 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1278 # We have non-source version versions
1279 @found = makesourceversions($param{package},undef,
1282 @fixed = makesourceversions($param{package},undef,
1286 if ($param{version} !~ m{/}) {
1287 my ($version) = makesourceversions($param{package},undef,
1290 $param{version} = $version if defined $version;
1292 # Figure out which source packages we need
1294 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1295 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1296 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1297 $param{version} =~ m{/};
1299 if (not defined $param{version_cache} or
1300 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1301 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1302 foreach my $source (keys %sources) {
1303 my $srchash = substr $source, 0, 1;
1304 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1305 if (not defined $version_fh) {
1306 # We only want to warn if it's a package which actually has a maintainer
1307 my $maints = getmaintainers();
1308 next if not exists $maints->{$source};
1309 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1312 $version->load($version_fh);
1314 if (defined $param{version_cache}) {
1315 $param{version_cache}{join(',',sort keys %sources)} = $version;
1319 $version = $param{version_cache}{join(',',sort keys %sources)};
1321 return $version->buggy($param{version},\@found,\@fixed);
1324 sub isstrongseverity {
1325 my $severity = shift;
1326 $severity = $config{default_severity} if
1327 not defined $severity or $severity eq '';
1328 return grep { $_ eq $severity } @{$config{strong_severities}};
1332 =head1 PRIVATE FUNCTIONS
1336 sub update_realtime {
1337 my ($file, %bugs) = @_;
1339 # update realtime index.db
1341 return () unless keys %bugs;
1342 my $idx_old = IO::File->new($file,'r')
1343 or die "Couldn't open ${file}: $!";
1344 my $idx_new = IO::File->new($file.'.new','w')
1345 or die "Couldn't open ${file}.new: $!";
1347 my $min_bug = min(keys %bugs);
1351 while($line = <$idx_old>) {
1352 @line = split /\s/, $line;
1353 # Two cases; replacing existing line or adding new line
1354 if (exists $bugs{$line[1]}) {
1355 my $new = $bugs{$line[1]};
1356 delete $bugs{$line[1]};
1357 $min_bug = min(keys %bugs);
1358 if ($new eq "NOCHANGE") {
1359 print {$idx_new} $line;
1360 $changed_bugs{$line[1]} = $line;
1361 } elsif ($new eq "REMOVE") {
1362 $changed_bugs{$line[1]} = $line;
1364 print {$idx_new} $new;
1365 $changed_bugs{$line[1]} = $line;
1369 while ($line[1] > $min_bug) {
1370 print {$idx_new} $bugs{$min_bug};
1371 delete $bugs{$min_bug};
1372 last unless keys %bugs;
1373 $min_bug = min(keys %bugs);
1375 print {$idx_new} $line;
1377 last unless keys %bugs;
1379 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1381 print {$idx_new} <$idx_old>;
1386 rename("$file.new", $file);
1388 return %changed_bugs;
1391 sub bughook_archive {
1393 &filelock("$config{spool_dir}/debbugs.trace.lock");
1394 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1395 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1396 map{($_,'REMOVE')} @refs);
1397 update_realtime("$config{spool_dir}/index.archive.realtime",
1403 my ( $type, %bugs_temp ) = @_;
1404 &filelock("$config{spool_dir}/debbugs.trace.lock");
1407 for my $bug (keys %bugs_temp) {
1408 my $data = $bugs_temp{$bug};
1409 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1411 my $whendone = "open";
1412 my $severity = $config{default_severity};
1413 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1414 $pkglist =~ s/^,+//;
1415 $pkglist =~ s/,+$//;
1416 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1417 $whendone = "done" if defined $data->{done} and length $data->{done};
1418 $severity = $data->{severity} if length $data->{severity};
1420 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1421 $pkglist, $bug, $data->{date}, $whendone,
1422 $data->{originator}, $severity, $data->{keywords};
1425 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);