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 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 # Add log last modified time
257 $data{log_modified} = (stat($log))[9];
258 $data{location} = $location;
259 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
260 $data{bug_num} = $param{bug};
267 lockreadbug($bug_num,$location)
269 Performs a filelock, then reads the bug; the bug is unlocked if the
270 return is undefined, otherwise, you need to call unfilelock or
273 See readbug above for information on what this returns
278 my ($lref, $location) = @_;
279 return read_bug(bug => $lref, location => $location, lock => 1);
282 =head2 lockreadbugmerge
284 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
286 Performs a filelock, then reads the bug. If the bug is merged, locks
287 the merge lock. Returns a list of the number of locks and the bug
292 sub lockreadbugmerge {
293 my ($bug_num,$location) = @_;
294 my $data = lockreadbug(@_);
295 if (not defined $data) {
298 if (not length $data->{mergedwith}) {
302 filelock("$config{spool_dir}/lock/merge");
303 $data = lockreadbug(@_);
304 if (not defined $data) {
311 =head2 lock_read_all_merged_bugs
313 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
315 Performs a filelock, then reads the bug passed. If the bug is merged,
316 locks the merge lock, then reads and locks all of the other merged
317 bugs. Returns a list of the number of locks and the bug data for all
320 Will also return undef if any of the merged bugs failed to be read,
321 even if all of the others were read properly.
325 sub lock_read_all_merged_bugs {
326 my ($bug_num,$location) = @_;
328 my @data = (lockreadbug(@_));
329 if (not @data or not defined $data[0]) {
330 return ($locks,undef);
333 if (not length $data[0]->{mergedwith}) {
334 return ($locks,@data);
338 filelock("$config{spool_dir}/lock/merge");
340 @data = (lockreadbug(@_));
341 if (not @data or not defined $data[0]) {
342 unfilelock(); #for merge lock above
344 return ($locks,undef);
347 my @bugs = split / /, $data[0]->{mergedwith};
348 for my $bug (@bugs) {
350 if ($bug ne $bug_num) {
351 $newdata = lockreadbug($bug,$location);
352 if (not defined $newdata) {
357 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
358 return ($locks,undef);
363 # perform a sanity check to make sure that the merged bugs are
364 # all merged with eachother
365 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
366 if ($newdata->{mergedwith} ne $expectmerge) {
370 die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
373 return ($locks,@data);
377 my @v1fieldorder = qw(originator date subject msgid package
378 keywords done forwarded mergedwith severity);
382 my $content = makestatus($status,$version)
383 my $content = makestatus($status);
385 Creates the content for a status file based on the $status hashref
388 Really only useful for writebug
390 Currently defaults to version 2 (non-encoded rfc1522 names) but will
391 eventually default to version 3. If you care, you should specify a
397 my ($data,$version) = @_;
398 $version = 2 unless defined $version;
402 my %newdata = %$data;
403 for my $field (qw(found fixed)) {
404 if (exists $newdata{$field}) {
405 $newdata{"${field}_date"} =
406 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
410 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
411 $newdata{$field} = join ' ', @{$newdata{$field}||[]};
415 for my $field (@rfc1522_fields) {
416 $newdata{$field} = encode_rfc1522($newdata{$field});
421 for my $field (@v1fieldorder) {
422 if (exists $newdata{$field} and defined $newdata{$field}) {
423 $contents .= "$newdata{$field}\n";
428 } elsif ($version == 2 or $version == 3) {
429 # Version 2 or 3. Add a file format version number for the sake of
430 # further extensibility in the future.
431 $contents .= "Format-Version: $version\n";
432 for my $field (keys %fields) {
433 if (exists $newdata{$field} and defined $newdata{$field}
434 and $newdata{$field} ne '') {
435 # Output field names in proper case, e.g. 'Merged-With'.
436 my $properfield = $fields{$field};
437 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
438 $contents .= "$properfield: $newdata{$field}\n";
448 writebug($bug_num,$status,$location,$minversion,$disablebughook)
450 Writes the bug status and summary files out.
452 Skips writting out a status file if minversion is 2
454 Does not call bughook if disablebughook is true.
459 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
462 my %outputs = (1 => 'status', 2 => 'summary');
463 for my $version (keys %outputs) {
464 next if defined $minversion and $version < $minversion;
465 my $status = getbugcomponent($ref, $outputs{$version}, $location);
466 die "can't find location for $ref" unless defined $status;
467 open(S,"> $status.new") || die "opening $status.new: $!";
468 print(S makestatus($data, $version)) ||
469 die "writing $status.new: $!";
470 close(S) || die "closing $status.new: $!";
476 rename("$status.new",$status) || die "installing new $status: $!";
479 # $disablebughook is a bit of a hack to let format migration scripts use
480 # this function rather than having to duplicate it themselves.
481 &bughook($change,$ref,$data) unless $disablebughook;
484 =head2 unlockwritebug
486 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
488 Writes a bug, then calls unfilelock; see writebug for what these
500 The following functions are exported with the :versions tag
502 =head2 addfoundversions
504 addfoundversions($status,$package,$version,$isbinary);
511 sub addfoundversions {
515 my $isbinary = shift;
516 return unless defined $version;
517 undef $package if $package =~ m[(?:\s|/)];
518 my $source = $package;
520 if (defined $package and $isbinary) {
521 my @srcinfo = binarytosource($package, $version, undef);
523 # We know the source package(s). Use a fully-qualified version.
524 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
527 # Otherwise, an unqualified version will have to do.
531 # Strip off various kinds of brain-damage.
533 $version =~ s/ *\(.*\)//;
534 $version =~ s/ +[A-Za-z].*//;
536 foreach my $ver (split /[,\s]+/, $version) {
537 my $sver = defined($source) ? "$source/$ver" : '';
538 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
539 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
541 @{$data->{fixed_versions}} =
542 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
546 =head2 removefoundversions
548 removefoundversions($data,$package,$versiontoremove)
550 Removes found versions from $data
552 If a version is fully qualified (contains /) only versions matching
553 exactly are removed. Otherwise, all versions matching the version
556 Currently $package and $isbinary are entirely ignored, but accepted
557 for backwards compatibilty.
561 sub removefoundversions {
565 my $isbinary = shift;
566 return unless defined $version;
568 foreach my $ver (split /[,\s]+/, $version) {
570 # fully qualified version
571 @{$data->{found_versions}} =
573 @{$data->{found_versions}};
576 # non qualified version; delete all matchers
577 @{$data->{found_versions}} =
578 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
579 @{$data->{found_versions}};
585 sub addfixedversions {
589 my $isbinary = shift;
590 return unless defined $version;
591 undef $package if defined $package and $package =~ m[(?:\s|/)];
592 my $source = $package;
594 if (defined $package and $isbinary) {
595 my @srcinfo = binarytosource($package, $version, undef);
597 # We know the source package(s). Use a fully-qualified version.
598 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
601 # Otherwise, an unqualified version will have to do.
605 # Strip off various kinds of brain-damage.
607 $version =~ s/ *\(.*\)//;
608 $version =~ s/ +[A-Za-z].*//;
610 foreach my $ver (split /[,\s]+/, $version) {
611 my $sver = defined($source) ? "$source/$ver" : '';
612 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
613 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
615 @{$data->{found_versions}} =
616 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
620 sub removefixedversions {
624 my $isbinary = shift;
625 return unless defined $version;
627 foreach my $ver (split /[,\s]+/, $version) {
629 # fully qualified version
630 @{$data->{fixed_versions}} =
632 @{$data->{fixed_versions}};
635 # non qualified version; delete all matchers
636 @{$data->{fixed_versions}} =
637 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
638 @{$data->{fixed_versions}};
649 Split a package string from the status file into a list of package names.
655 return unless defined $pkgs;
656 return map lc, split /[ \t?,()]+/, $pkgs;
660 =head2 bug_archiveable
662 bug_archiveable(bug => $bug_num);
668 =item bug -- bug number (required)
670 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
672 =item version -- Debbugs::Version information (optional)
674 =item days_until -- return days until the bug can be archived
678 Returns 1 if the bug can be archived
679 Returns 0 if the bug cannot be archived
681 If days_until is true, returns the number of days until the bug can be
682 archived, -1 if it cannot be archived. 0 means that the bug can be
683 archived the next time the archiver runs.
685 Returns undef on failure.
689 # This will eventually need to be fixed before we start using mod_perl
690 our $version_cache = {};
692 my %param = validate_with(params => \@_,
693 spec => {bug => {type => SCALAR,
696 status => {type => HASHREF,
699 days_until => {type => BOOLEAN,
702 ignore_time => {type => BOOLEAN,
707 # This is what we return if the bug cannot be archived.
708 my $cannot_archive = $param{days_until}?-1:0;
709 # read the status information
710 my $status = $param{status};
711 if (not exists $param{status} or not defined $status) {
712 $status = read_bug(bug=>$param{bug});
713 if (not defined $status) {
714 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
718 # Bugs can be archived if they are
720 if (not defined $status->{done} or not length $status->{done}) {
721 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
722 return $cannot_archive
724 # Check to make sure that the bug has none of the unremovable tags set
725 if (@{$config{removal_unremovable_tags}}) {
726 for my $tag (split ' ', ($status->{tags}||'')) {
727 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
728 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
729 return $cannot_archive;
734 # If we just are checking if the bug can be archived, we'll not even bother
735 # checking the versioning information if the bug has been -done for less than 28 days.
736 my $log_file = getbugcomponent($param{bug},'log');
737 if (not defined $log_file) {
738 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
739 return $cannot_archive;
741 my $max_log_age = max(map {$config{remove_age} - -M $_}
742 $log_file, map {my $log = getbugcomponent($_,'log');
743 defined $log ? ($log) : ();
745 split / /, $status->{mergedwith}
747 if (not $param{days_until} and not $param{ignore_time}
750 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
751 return $cannot_archive;
753 # At this point, we have to get the versioning information for this bug.
754 # We examine the set of distribution tags. If a bug has no distribution
755 # tags set, we assume a default set, otherwise we use the tags the bug
758 # In cases where we are assuming a default set, if the severity
759 # is strong, we use the strong severity default; otherwise, we
760 # use the normal default.
762 # There must be fixed_versions for us to look at the versioning
764 my $min_fixed_time = time;
765 my $min_archive_days = 0;
766 if (@{$status->{fixed_versions}}) {
768 @dist_tags{@{$config{removal_distribution_tags}}} =
769 (1) x @{$config{removal_distribution_tags}};
771 for my $tag (split ' ', ($status->{tags}||'')) {
772 next unless exists $config{distribution_aliases}{$tag};
773 next unless $dist_tags{$config{distribution_aliases}{$tag}};
774 $dists{$config{distribution_aliases}{$tag}} = 1;
776 if (not keys %dists) {
777 if (isstrongseverity($status->{severity})) {
778 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
779 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
782 @dists{@{$config{removal_default_distribution_tags}}} =
783 (1) x @{$config{removal_default_distribution_tags}};
787 my @sourceversions = get_versions(package => $status->{package},
788 dist => [keys %dists],
791 @source_versions{@sourceversions} = (1) x @sourceversions;
792 # If the bug has not been fixed in the versions actually
793 # distributed, then it cannot be archived.
794 if ('found' eq max_buggy(bug => $param{bug},
795 sourceversions => [keys %source_versions],
796 found => $status->{found_versions},
797 fixed => $status->{fixed_versions},
798 version_cache => $version_cache,
799 package => $status->{package},
801 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
802 return $cannot_archive;
804 # Since the bug has at least been fixed in the architectures
805 # that matters, we check to see how long it has been fixed.
807 # If $param{ignore_time}, then we should ignore time.
808 if ($param{ignore_time}) {
809 return $param{days_until}?0:1;
812 # To do this, we order the times from most recent to oldest;
813 # when we come to the first found version, we stop.
814 # If we run out of versions, we only report the time of the
816 my %time_versions = get_versions(package => $status->{package},
817 dist => [keys %dists],
821 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
822 my $buggy = buggy(bug => $param{bug},
824 found => $status->{found_versions},
825 fixed => $status->{fixed_versions},
826 version_cache => $version_cache,
827 package => $status->{package},
829 last if $buggy eq 'found';
830 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
832 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
833 # if there are no versions in the archive at all, then
834 # we can archive if enough days have passed
837 # If $param{ignore_time}, then we should ignore time.
838 if ($param{ignore_time}) {
839 return $param{days_until}?0:1;
841 # 6. at least 28 days have passed since the last action has occured or the bug was closed
842 my $age = ceil($max_log_age);
843 if ($age > 0 or $min_archive_days > 0) {
844 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
845 return $param{days_until}?max($age,$min_archive_days):0;
848 return $param{days_until}?0:1;
853 =head2 get_bug_status
855 my $status = get_bug_status(bug => $nnn);
857 my $status = get_bug_status($bug_num)
863 =item bug -- scalar bug number
865 =item status -- optional hashref of bug status as returned by readbug
866 (can be passed to avoid rereading the bug information)
868 =item bug_index -- optional tied index of bug status infomration;
869 currently not correctly implemented.
871 =item version -- optional version(s) to check package status at
873 =item dist -- optional distribution(s) to check package status at
875 =item arch -- optional architecture(s) to check package status at
877 =item bugusertags -- optional hashref of bugusertags
879 =item sourceversion -- optional arrayref of source/version; overrides
880 dist, arch, and version. [The entries in this array must be in the
881 "source/version" format.] Eventually this can be used to for caching.
883 =item indicatesource -- if true, indicate which source packages this
884 bug could belong to (or does belong to in the case of bugs assigned to
885 a source package). Defaults to true.
889 Note: Currently the version information is cached; this needs to be
890 changed before using this function in long lived programs.
898 my %param = validate_with(params => \@_,
899 spec => {bug => {type => SCALAR,
902 status => {type => HASHREF,
905 bug_index => {type => OBJECT,
908 version => {type => SCALAR|ARRAYREF,
911 dist => {type => SCALAR|ARRAYREF,
914 arch => {type => SCALAR|ARRAYREF,
917 bugusertags => {type => HASHREF,
920 sourceversions => {type => ARRAYREF,
923 indicatesource => {type => BOOLEAN,
930 if (defined $param{bug_index} and
931 exists $param{bug_index}{$param{bug}}) {
932 %status = %{ $param{bug_index}{$param{bug}} };
933 $status{pending} = $status{ status };
934 $status{id} = $param{bug};
937 if (defined $param{status}) {
938 %status = %{$param{status}};
941 my $location = getbuglocation($param{bug}, 'summary');
942 return {} if not defined $location or not length $location;
943 %status = %{ readbug( $param{bug}, $location ) };
945 $status{id} = $param{bug};
947 if (defined $param{bugusertags}{$param{bug}}) {
948 $status{keywords} = "" unless defined $status{keywords};
949 $status{keywords} .= " " unless $status{keywords} eq "";
950 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
952 $status{tags} = $status{keywords};
953 my %tags = map { $_ => 1 } split ' ', $status{tags};
955 $status{package} = '' if not defined $status{package};
956 $status{"package"} =~ s/\s*$//;
957 # if we aren't supposed to indicate the source, we'll return
959 $status{source} = 'unknown';
960 if ($param{indicatesource}) {
961 my @packages = split /\s*,\s*/, $status{package};
963 for my $package (@packages) {
964 next if $package eq '';
965 if ($package =~ /^src\:$/) {
969 push @source, binarytosource($package);
973 $status{source} = join(', ',@source);
977 $status{"package"} = 'unknown' if ($status{"package"} eq '');
978 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
980 $status{"pending"} = 'pending';
981 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
982 $status{"pending"} = 'pending-fixed' if ($tags{pending});
983 $status{"pending"} = 'fixed' if ($tags{fixed});
986 my $presence = bug_presence(status => \%status,
987 map{(exists $param{$_})?($_,$param{$_}):()}
988 qw(bug sourceversions arch dist version found fixed package)
990 if (defined $presence) {
991 if ($presence eq 'fixed') {
992 $status{pending} = 'done';
994 elsif ($presence eq 'absent') {
995 $status{pending} = 'absent';
1003 my $precence = bug_presence(bug => nnn,
1007 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1008 is found, absent, fixed, or no information is available in the
1009 distribution (dist) and/or architecture (arch) specified.
1016 =item bug -- scalar bug number
1018 =item status -- optional hashref of bug status as returned by readbug
1019 (can be passed to avoid rereading the bug information)
1021 =item bug_index -- optional tied index of bug status infomration;
1022 currently not correctly implemented.
1024 =item version -- optional version to check package status at
1026 =item dist -- optional distribution to check package status at
1028 =item arch -- optional architecture to check package status at
1030 =item sourceversion -- optional arrayref of source/version; overrides
1031 dist, arch, and version. [The entries in this array must be in the
1032 "source/version" format.] Eventually this can be used to for caching.
1039 my %param = validate_with(params => \@_,
1040 spec => {bug => {type => SCALAR,
1043 status => {type => HASHREF,
1046 version => {type => SCALAR|ARRAYREF,
1049 dist => {type => SCALAR|ARRAYREF,
1052 arch => {type => SCALAR|ARRAYREF,
1055 sourceversions => {type => ARRAYREF,
1061 if (defined $param{status}) {
1062 %status = %{$param{status}};
1065 my $location = getbuglocation($param{bug}, 'summary');
1066 return {} if not length $location;
1067 %status = %{ readbug( $param{bug}, $location ) };
1071 my $pseudo_desc = getpseudodesc();
1072 if (not exists $param{sourceversions}) {
1074 # pseudopackages do not have source versions by definition.
1075 if (exists $pseudo_desc->{$status{package}}) {
1078 elsif (defined $param{version}) {
1079 foreach my $arch (make_list($param{arch})) {
1080 for my $package (split /\s*,\s*/, $status{package}) {
1081 my @temp = makesourceversions($package,
1083 make_list($param{version})
1085 @sourceversions{@temp} = (1) x @temp;
1088 } elsif (defined $param{dist}) {
1089 my %affects_distribution_tags;
1090 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1091 (1) x @{$config{affects_distribution_tags}};
1092 my $some_distributions_disallowed = 0;
1093 my %allowed_distributions;
1094 for my $tag (split ' ', ($status{tags}||'')) {
1095 if (exists $config{distribution_aliases}{$tag} and
1096 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1097 $some_distributions_disallowed = 1;
1098 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1100 elsif (exists $affects_distribution_tags{$tag}) {
1101 $some_distributions_disallowed = 1;
1102 $allowed_distributions{$tag} = 1;
1105 foreach my $arch (make_list($param{arch})) {
1106 for my $package (split /\s*,\s*/, $status{package}) {
1108 foreach my $dist (make_list($param{dist})) {
1109 # if some distributions are disallowed,
1110 # and this isn't an allowed
1111 # distribution, then we ignore this
1112 # distribution for the purposees of
1114 if ($some_distributions_disallowed and
1115 not exists $allowed_distributions{$dist}) {
1118 push @versions, getversions($package, $dist, $arch);
1120 next unless @versions;
1121 my @temp = makesourceversions($package,
1125 @sourceversions{@temp} = (1) x @temp;
1130 # TODO: This should probably be handled further out for efficiency and
1131 # for more ease of distinguishing between pkg= and src= queries.
1132 # DLA: src= queries should just pass arch=source, and they'll be happy.
1133 @sourceversions = keys %sourceversions;
1136 @sourceversions = @{$param{sourceversions}};
1138 my $maxbuggy = 'undef';
1139 if (@sourceversions) {
1140 $maxbuggy = max_buggy(bug => $param{bug},
1141 sourceversions => \@sourceversions,
1142 found => $status{found_versions},
1143 fixed => $status{fixed_versions},
1144 package => $status{package},
1145 version_cache => $version_cache,
1148 elsif (defined $param{dist} and
1149 not exists $pseudo_desc->{$status{package}}) {
1152 if (length($status{done}) and
1153 (not @sourceversions or not @{$status{fixed_versions}})) {
1168 =item bug -- scalar bug number
1170 =item sourceversion -- optional arrayref of source/version; overrides
1171 dist, arch, and version. [The entries in this array must be in the
1172 "source/version" format.] Eventually this can be used to for caching.
1176 Note: Currently the version information is cached; this needs to be
1177 changed before using this function in long lived programs.
1182 my %param = validate_with(params => \@_,
1183 spec => {bug => {type => SCALAR,
1186 sourceversions => {type => ARRAYREF,
1189 found => {type => ARRAYREF,
1192 fixed => {type => ARRAYREF,
1195 package => {type => SCALAR,
1197 version_cache => {type => HASHREF,
1202 # Resolve bugginess states (we might be looking at multiple
1203 # architectures, say). Found wins, then fixed, then absent.
1204 my $maxbuggy = 'absent';
1205 for my $package (split /\s*,\s*/, $param{package}) {
1206 for my $version (@{$param{sourceversions}}) {
1207 my $buggy = buggy(bug => $param{bug},
1208 version => $version,
1209 found => $param{found},
1210 fixed => $param{fixed},
1211 version_cache => $param{version_cache},
1212 package => $package,
1214 if ($buggy eq 'found') {
1216 } elsif ($buggy eq 'fixed') {
1217 $maxbuggy = 'fixed';
1234 Returns the output of Debbugs::Versions::buggy for a particular
1235 package, version and found/fixed set. Automatically turns found, fixed
1236 and version into source/version strings.
1238 Caching can be had by using the version_cache, but no attempt to check
1239 to see if the on disk information is more recent than the cache is
1240 made. [This will need to be fixed for long-lived processes.]
1245 my %param = validate_with(params => \@_,
1246 spec => {bug => {type => SCALAR,
1249 found => {type => ARRAYREF,
1252 fixed => {type => ARRAYREF,
1255 version_cache => {type => HASHREF,
1258 package => {type => SCALAR,
1260 version => {type => SCALAR,
1264 my @found = @{$param{found}};
1265 my @fixed = @{$param{fixed}};
1266 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1267 # We have non-source version versions
1268 @found = makesourceversions($param{package},undef,
1271 @fixed = makesourceversions($param{package},undef,
1275 if ($param{version} !~ m{/}) {
1276 my ($version) = makesourceversions($param{package},undef,
1279 $param{version} = $version if defined $version;
1281 # Figure out which source packages we need
1283 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1284 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1285 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1286 $param{version} =~ m{/};
1288 if (not defined $param{version_cache} or
1289 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1290 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1291 foreach my $source (keys %sources) {
1292 my $srchash = substr $source, 0, 1;
1293 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1294 if (not defined $version_fh) {
1295 # We only want to warn if it's a package which actually has a maintainer
1296 my $maints = getmaintainers();
1297 next if not exists $maints->{$source};
1298 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1301 $version->load($version_fh);
1303 if (defined $param{version_cache}) {
1304 $param{version_cache}{join(',',sort keys %sources)} = $version;
1308 $version = $param{version_cache}{join(',',sort keys %sources)};
1310 return $version->buggy($param{version},\@found,\@fixed);
1313 sub isstrongseverity {
1314 my $severity = shift;
1315 $severity = $config{default_severity} if
1316 not defined $severity or $severity eq '';
1317 return grep { $_ eq $severity } @{$config{strong_severities}};
1321 =head1 PRIVATE FUNCTIONS
1325 sub update_realtime {
1326 my ($file, %bugs) = @_;
1328 # update realtime index.db
1330 return () unless keys %bugs;
1331 my $idx_old = IO::File->new($file,'r')
1332 or die "Couldn't open ${file}: $!";
1333 my $idx_new = IO::File->new($file.'.new','w')
1334 or die "Couldn't open ${file}.new: $!";
1336 my $min_bug = min(keys %bugs);
1340 while($line = <$idx_old>) {
1341 @line = split /\s/, $line;
1342 # Two cases; replacing existing line or adding new line
1343 if (exists $bugs{$line[1]}) {
1344 my $new = $bugs{$line[1]};
1345 delete $bugs{$line[1]};
1346 $min_bug = min(keys %bugs);
1347 if ($new eq "NOCHANGE") {
1348 print {$idx_new} $line;
1349 $changed_bugs{$line[1]} = $line;
1350 } elsif ($new eq "REMOVE") {
1351 $changed_bugs{$line[1]} = $line;
1353 print {$idx_new} $new;
1354 $changed_bugs{$line[1]} = $line;
1358 while ($line[1] > $min_bug) {
1359 print {$idx_new} $bugs{$min_bug};
1360 delete $bugs{$min_bug};
1361 last unless keys %bugs;
1362 $min_bug = min(keys %bugs);
1364 print {$idx_new} $line;
1366 last unless keys %bugs;
1368 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1370 print {$idx_new} <$idx_old>;
1375 rename("$file.new", $file);
1377 return %changed_bugs;
1380 sub bughook_archive {
1382 &filelock("$config{spool_dir}/debbugs.trace.lock");
1383 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1384 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1385 map{($_,'REMOVE')} @refs);
1386 update_realtime("$config{spool_dir}/index.archive.realtime",
1392 my ( $type, %bugs_temp ) = @_;
1393 &filelock("$config{spool_dir}/debbugs.trace.lock");
1396 for my $bug (keys %bugs_temp) {
1397 my $data = $bugs_temp{$bug};
1398 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1400 my $whendone = "open";
1401 my $severity = $config{default_severity};
1402 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1403 $pkglist =~ s/^,+//;
1404 $pkglist =~ s/,+$//;
1405 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1406 $whendone = "done" if defined $data->{done} and length $data->{done};
1407 $severity = $data->{severity} if length $data->{severity};
1409 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1410 $pkglist, $bug, $data->{date}, $whendone,
1411 $data->{originator}, $severity, $data->{keywords};
1414 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);