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)],
69 Exporter::export_ok_tags(qw(status read write versions hook));
70 $EXPORT_TAGS{all} = [@EXPORT_OK];
76 readbug($bug_num,$location)
79 Reads a summary file from the archive given a bug number and a bug
80 location. Valid locations are those understood by L</getbugcomponent>
85 my %fields = (originator => 'submitter',
88 msgid => 'message-id',
89 'package' => 'package',
92 forwarded => 'forwarded-to',
93 mergedwith => 'merged-with',
94 severity => 'severity',
96 found_versions => 'found-in',
97 found_date => 'found-date',
98 fixed_versions => 'fixed-in',
99 fixed_date => 'fixed-date',
101 blockedby => 'blocked-by',
102 unarchived => 'unarchived',
105 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
106 my @rfc1522_fields = qw(originator subject done forwarded owner);
109 return read_bug(bug => $_[0],
110 (@_ > 1)?(location => $_[1]):()
116 read_bug(bug => $bug_num,
117 location => 'archive',
119 read_bug(summary => 'path/to/bugnum.summary');
122 A more complete function than readbug; it enables you to pass a full
123 path to the summary file instead of the bug number and/or location.
129 =item bug -- the bug number
131 =item location -- optional location which is passed to getbugcomponent
133 =item summary -- complete path to the .summary file which will be read
135 =item lock -- whether to obtain a lock for the bug to prevent
136 something modifying it while the bug has been read. You B<must> call
137 C<unfilelock();> if something not undef is returned from read_bug.
141 One of C<bug> or C<summary> must be passed. This function will return
142 undef on failure, and will die if improper arguments are passed.
150 my %param = validate_with(params => \@_,
151 spec => {bug => {type => SCALAR,
155 # negative bugnumbers
158 location => {type => SCALAR|UNDEF,
161 summary => {type => SCALAR,
164 lock => {type => BOOLEAN,
169 die "One of bug or summary must be passed to read_bug"
170 if not exists $param{bug} and not exists $param{summary};
174 if (not defined $param{summary}) {
176 ($lref,$location) = @param{qw(bug location)};
177 if (not defined $location) {
178 $location = getbuglocation($lref,'summary');
179 return undef if not defined $location;
181 $status = getbugcomponent($lref, 'summary', $location);
182 $log = getbugcomponent($lref, 'log' , $location);
183 return undef unless defined $status;
186 $status = $param{summary};
188 $log =~ s/\.summary$/.log/;
189 ($location) = $status =~ m/(db-h|db|archive)/;
192 filelock("$config{spool_dir}/lock/$param{bug}");
194 my $status_fh = IO::File->new($status, 'r');
195 if (not defined $status_fh) {
196 warn "Unable to open $status for reading: $!";
208 while (<$status_fh>) {
211 $version = $1 if /^Format-Version: ([0-9]+)/i;
214 # Version 3 is the latest format version currently supported.
216 warn "Unsupported status version '$version'";
223 my %namemap = reverse %fields;
224 for my $line (@lines) {
225 if ($line =~ /(\S+?): (.*)/) {
226 my ($name, $value) = (lc $1, $2);
227 $data{$namemap{$name}} = $value if exists $namemap{$name};
230 for my $field (keys %fields) {
231 $data{$field} = '' unless exists $data{$field};
234 $data{severity} = $config{default_severity} if $data{severity} eq '';
235 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
236 $data{$field} = [split ' ', $data{$field}];
238 for my $field (qw(found fixed)) {
239 # create the found/fixed hashes which indicate when a
240 # particular version was marked found or marked fixed.
241 @{$data{$field}}{@{$data{"${field}_versions"}}} =
242 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
243 @{$data{"${field}_date"}});
247 for my $field (@rfc1522_fields) {
248 $data{$field} = decode_rfc1522($data{$field});
251 # Add log last modified time
252 $data{log_modified} = (stat($log))[9];
253 $data{location} = $location;
254 $data{archived} = $location eq 'archive';
255 $data{bug_num} = $param{bug};
262 lockreadbug($bug_num,$location)
264 Performs a filelock, then reads the bug; the bug is unlocked if the
265 return is undefined, otherwise, you need to call unfilelock or
268 See readbug above for information on what this returns
273 my ($lref, $location) = @_;
274 return read_bug(bug => $lref, location => $location, lock => 1);
277 =head2 lockreadbugmerge
279 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
281 Performs a filelock, then reads the bug. If the bug is merged, locks
282 the merge lock. Returns a list of the number of locks and the bug
287 sub lockreadbugmerge {
288 my ($bug_num,$location) = @_;
289 my $data = lockreadbug(@_);
290 if (not defined $data) {
293 if (not length $data->{mergedwith}) {
297 filelock("$config{spool_dir}/lock/merge");
298 $data = lockreadbug(@_);
299 if (not defined $data) {
306 =head2 lock_read_all_merged_bugs
308 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
310 Performs a filelock, then reads the bug passed. If the bug is merged,
311 locks the merge lock, then reads and locks all of the other merged
312 bugs. Returns a list of the number of locks and the bug data for all
315 Will also return undef if any of the merged bugs failed to be read,
316 even if all of the others were read properly.
320 sub lock_read_all_merged_bugs {
321 my ($bug_num,$location) = @_;
322 my @data = (lockreadbug(@_));
323 if (not @data and not defined $data[0]) {
326 if (not length $data[0]->{mergedwith}) {
330 filelock("$config{spool_dir}/lock/merge");
332 @data = (lockreadbug(@_));
333 if (not @data and not defined $data[0]) {
334 unfilelock(); #for merge lock above
338 my @bugs = split / /, $data[0]->{mergedwith};
339 for my $bug (@bugs) {
341 if ($bug ne $bug_num) {
342 $newdata = lockreadbug($bug,$location);
343 if (not defined $newdata) {
348 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
349 return ($locks,undef);
354 # perform a sanity check to make sure that the merged bugs are
355 # all merged with eachother
356 my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
357 if ($newdata->{mergedwith} ne $expectmerge) {
361 die "Bug $bug_num differs from bug $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
368 my @v1fieldorder = qw(originator date subject msgid package
369 keywords done forwarded mergedwith severity);
373 my $content = makestatus($status,$version)
374 my $content = makestatus($status);
376 Creates the content for a status file based on the $status hashref
379 Really only useful for writebug
381 Currently defaults to version 2 (non-encoded rfc1522 names) but will
382 eventually default to version 3. If you care, you should specify a
388 my ($data,$version) = @_;
389 $version = 2 unless defined $version;
393 my %newdata = %$data;
394 for my $field (qw(found fixed)) {
395 if (exists $newdata{$field}) {
396 $newdata{"${field}_date"} =
397 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
401 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
402 $newdata{$field} = join ' ', @{$newdata{$field}||[]};
406 for my $field (@rfc1522_fields) {
407 $newdata{$field} = encode_rfc1522($newdata{$field});
412 for my $field (@v1fieldorder) {
413 if (exists $newdata{$field} and defined $newdata{$field}) {
414 $contents .= "$newdata{$field}\n";
419 } elsif ($version == 2 or $version == 3) {
420 # Version 2 or 3. Add a file format version number for the sake of
421 # further extensibility in the future.
422 $contents .= "Format-Version: $version\n";
423 for my $field (keys %fields) {
424 if (exists $newdata{$field} and defined $newdata{$field}
425 and $newdata{$field} ne '') {
426 # Output field names in proper case, e.g. 'Merged-With'.
427 my $properfield = $fields{$field};
428 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
429 $contents .= "$properfield: $newdata{$field}\n";
439 writebug($bug_num,$status,$location,$minversion,$disablebughook)
441 Writes the bug status and summary files out.
443 Skips writting out a status file if minversion is 2
445 Does not call bughook if disablebughook is true.
450 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
453 my %outputs = (1 => 'status', 2 => 'summary');
454 for my $version (keys %outputs) {
455 next if defined $minversion and $version < $minversion;
456 my $status = getbugcomponent($ref, $outputs{$version}, $location);
457 die "can't find location for $ref" unless defined $status;
458 open(S,"> $status.new") || die "opening $status.new: $!";
459 print(S makestatus($data, $version)) ||
460 die "writing $status.new: $!";
461 close(S) || die "closing $status.new: $!";
467 rename("$status.new",$status) || die "installing new $status: $!";
470 # $disablebughook is a bit of a hack to let format migration scripts use
471 # this function rather than having to duplicate it themselves.
472 &bughook($change,$ref,$data) unless $disablebughook;
475 =head2 unlockwritebug
477 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
479 Writes a bug, then calls unfilelock; see writebug for what these
491 The following functions are exported with the :versions tag
493 =head2 addfoundversions
495 addfoundversions($status,$package,$version,$isbinary);
502 sub addfoundversions {
506 my $isbinary = shift;
507 return unless defined $version;
508 undef $package if $package =~ m[(?:\s|/)];
509 my $source = $package;
511 if (defined $package and $isbinary) {
512 my @srcinfo = binarytosource($package, $version, undef);
514 # We know the source package(s). Use a fully-qualified version.
515 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
518 # Otherwise, an unqualified version will have to do.
522 # Strip off various kinds of brain-damage.
524 $version =~ s/ *\(.*\)//;
525 $version =~ s/ +[A-Za-z].*//;
527 foreach my $ver (split /[,\s]+/, $version) {
528 my $sver = defined($source) ? "$source/$ver" : '';
529 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
530 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
532 @{$data->{fixed_versions}} =
533 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
537 =head2 removefoundversions
539 removefoundversions($data,$package,$versiontoremove)
541 Removes found versions from $data
543 If a version is fully qualified (contains /) only versions matching
544 exactly are removed. Otherwise, all versions matching the version
547 Currently $package and $isbinary are entirely ignored, but accepted
548 for backwards compatibilty.
552 sub removefoundversions {
556 my $isbinary = shift;
557 return unless defined $version;
559 foreach my $ver (split /[,\s]+/, $version) {
561 # fully qualified version
562 @{$data->{found_versions}} =
564 @{$data->{found_versions}};
567 # non qualified version; delete all matchers
568 @{$data->{found_versions}} =
569 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
570 @{$data->{found_versions}};
576 sub addfixedversions {
580 my $isbinary = shift;
581 return unless defined $version;
582 undef $package if defined $package and $package =~ m[(?:\s|/)];
583 my $source = $package;
585 if (defined $package and $isbinary) {
586 my @srcinfo = binarytosource($package, $version, undef);
588 # We know the source package(s). Use a fully-qualified version.
589 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
592 # Otherwise, an unqualified version will have to do.
596 # Strip off various kinds of brain-damage.
598 $version =~ s/ *\(.*\)//;
599 $version =~ s/ +[A-Za-z].*//;
601 foreach my $ver (split /[,\s]+/, $version) {
602 my $sver = defined($source) ? "$source/$ver" : '';
603 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
604 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
606 @{$data->{found_versions}} =
607 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
611 sub removefixedversions {
615 my $isbinary = shift;
616 return unless defined $version;
618 foreach my $ver (split /[,\s]+/, $version) {
620 # fully qualified version
621 @{$data->{fixed_versions}} =
623 @{$data->{fixed_versions}};
626 # non qualified version; delete all matchers
627 @{$data->{fixed_versions}} =
628 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
629 @{$data->{fixed_versions}};
640 Split a package string from the status file into a list of package names.
646 return unless defined $pkgs;
647 return map lc, split /[ \t?,()]+/, $pkgs;
651 =head2 bug_archiveable
653 bug_archiveable(bug => $bug_num);
659 =item bug -- bug number (required)
661 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
663 =item version -- Debbugs::Version information (optional)
665 =item days_until -- return days until the bug can be archived
669 Returns 1 if the bug can be archived
670 Returns 0 if the bug cannot be archived
672 If days_until is true, returns the number of days until the bug can be
673 archived, -1 if it cannot be archived. 0 means that the bug can be
674 archived the next time the archiver runs.
676 Returns undef on failure.
680 # This will eventually need to be fixed before we start using mod_perl
681 our $version_cache = {};
683 my %param = validate_with(params => \@_,
684 spec => {bug => {type => SCALAR,
687 status => {type => HASHREF,
690 days_until => {type => BOOLEAN,
693 ignore_time => {type => BOOLEAN,
698 # This is what we return if the bug cannot be archived.
699 my $cannot_archive = $param{days_until}?-1:0;
700 # read the status information
701 my $status = $param{status};
702 if (not exists $param{status} or not defined $status) {
703 $status = read_bug(bug=>$param{bug});
704 if (not defined $status) {
705 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
709 # Bugs can be archived if they are
711 if (not defined $status->{done} or not length $status->{done}) {
712 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
713 return $cannot_archive
715 # Check to make sure that the bug has none of the unremovable tags set
716 if (@{$config{removal_unremovable_tags}}) {
717 for my $tag (split ' ', ($status->{tags}||'')) {
718 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
719 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
720 return $cannot_archive;
725 # If we just are checking if the bug can be archived, we'll not even bother
726 # checking the versioning information if the bug has been -done for less than 28 days.
727 my $log_file = getbugcomponent($param{bug},'log');
728 if (not defined $log_file) {
729 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
730 return $cannot_archive;
732 my $max_log_age = max(map {$config{remove_age} - -M $_}
733 $log_file, map {my $log = getbugcomponent($_,'log');
734 defined $log ? ($log) : ();
736 split / /, $status->{mergedwith}
738 if (not $param{days_until} and not $param{ignore_time}
741 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
742 return $cannot_archive;
744 # At this point, we have to get the versioning information for this bug.
745 # We examine the set of distribution tags. If a bug has no distribution
746 # tags set, we assume a default set, otherwise we use the tags the bug
749 # In cases where we are assuming a default set, if the severity
750 # is strong, we use the strong severity default; otherwise, we
751 # use the normal default.
753 # There must be fixed_versions for us to look at the versioning
755 my $min_fixed_time = time;
756 my $min_archive_days = 0;
757 if (@{$status->{fixed_versions}}) {
759 @dist_tags{@{$config{removal_distribution_tags}}} =
760 (1) x @{$config{removal_distribution_tags}};
762 for my $tag (split ' ', ($status->{tags}||'')) {
763 next unless exists $config{distribution_aliases}{$tag};
764 next unless $dist_tags{$config{distribution_aliases}{$tag}};
765 $dists{$config{distribution_aliases}{$tag}} = 1;
767 if (not keys %dists) {
768 if (isstrongseverity($status->{severity})) {
769 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
770 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
773 @dists{@{$config{removal_default_distribution_tags}}} =
774 (1) x @{$config{removal_default_distribution_tags}};
778 my @sourceversions = get_versions(package => $status->{package},
779 dist => [keys %dists],
782 @source_versions{@sourceversions} = (1) x @sourceversions;
783 # If the bug has not been fixed in the versions actually
784 # distributed, then it cannot be archived.
785 if ('found' eq max_buggy(bug => $param{bug},
786 sourceversions => [keys %source_versions],
787 found => $status->{found_versions},
788 fixed => $status->{fixed_versions},
789 version_cache => $version_cache,
790 package => $status->{package},
792 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
793 return $cannot_archive;
795 # Since the bug has at least been fixed in the architectures
796 # that matters, we check to see how long it has been fixed.
798 # If $param{ignore_time}, then we should ignore time.
799 if ($param{ignore_time}) {
800 return $param{days_until}?0:1;
803 # To do this, we order the times from most recent to oldest;
804 # when we come to the first found version, we stop.
805 # If we run out of versions, we only report the time of the
807 my %time_versions = get_versions(package => $status->{package},
808 dist => [keys %dists],
812 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
813 my $buggy = buggy(bug => $param{bug},
815 found => $status->{found_versions},
816 fixed => $status->{fixed_versions},
817 version_cache => $version_cache,
818 package => $status->{package},
820 last if $buggy eq 'found';
821 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
823 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
824 # if there are no versions in the archive at all, then
825 # we can archive if enough days have passed
828 # If $param{ignore_time}, then we should ignore time.
829 if ($param{ignore_time}) {
830 return $param{days_until}?0:1;
832 # 6. at least 28 days have passed since the last action has occured or the bug was closed
833 my $age = ceil($max_log_age);
834 if ($age > 0 or $min_archive_days > 0) {
835 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
836 return $param{days_until}?max($age,$min_archive_days):0;
839 return $param{days_until}?0:1;
844 =head2 get_bug_status
846 my $status = get_bug_status(bug => $nnn);
848 my $status = get_bug_status($bug_num)
854 =item bug -- scalar bug number
856 =item status -- optional hashref of bug status as returned by readbug
857 (can be passed to avoid rereading the bug information)
859 =item bug_index -- optional tied index of bug status infomration;
860 currently not correctly implemented.
862 =item version -- optional version(s) to check package status at
864 =item dist -- optional distribution(s) to check package status at
866 =item arch -- optional architecture(s) to check package status at
868 =item bugusertags -- optional hashref of bugusertags
870 =item sourceversion -- optional arrayref of source/version; overrides
871 dist, arch, and version. [The entries in this array must be in the
872 "source/version" format.] Eventually this can be used to for caching.
874 =item indicatesource -- if true, indicate which source packages this
875 bug could belong to. Defaults to false. [Note that eventually we will
876 properly allow bugs that only affect a source package, and this will
881 Note: Currently the version information is cached; this needs to be
882 changed before using this function in long lived programs.
890 my %param = validate_with(params => \@_,
891 spec => {bug => {type => SCALAR,
894 status => {type => HASHREF,
897 bug_index => {type => OBJECT,
900 version => {type => SCALAR|ARRAYREF,
903 dist => {type => SCALAR|ARRAYREF,
906 arch => {type => SCALAR|ARRAYREF,
909 bugusertags => {type => HASHREF,
912 sourceversions => {type => ARRAYREF,
915 indicatesource => {type => BOOLEAN,
922 if (defined $param{bug_index} and
923 exists $param{bug_index}{$param{bug}}) {
924 %status = %{ $param{bug_index}{$param{bug}} };
925 $status{pending} = $status{ status };
926 $status{id} = $param{bug};
929 if (defined $param{status}) {
930 %status = %{$param{status}};
933 my $location = getbuglocation($param{bug}, 'summary');
934 return {} if not defined $location or not length $location;
935 %status = %{ readbug( $param{bug}, $location ) };
937 $status{id} = $param{bug};
939 if (defined $param{bugusertags}{$param{bug}}) {
940 $status{keywords} = "" unless defined $status{keywords};
941 $status{keywords} .= " " unless $status{keywords} eq "";
942 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
944 $status{tags} = $status{keywords};
945 my %tags = map { $_ => 1 } split ' ', $status{tags};
947 $status{"package"} =~ s/\s*$//;
948 if ($param{indicatesource} and $status{package} ne '') {
949 $status{source} = join(', ',binarytosource($status{package}));
952 $status{source} = 'unknown';
954 $status{"package"} = 'unknown' if ($status{"package"} eq '');
955 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
957 $status{"pending"} = 'pending';
958 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
959 $status{"pending"} = 'pending-fixed' if ($tags{pending});
960 $status{"pending"} = 'fixed' if ($tags{fixed});
963 my $presence = bug_presence(status => \%status,
964 map{(exists $param{$_})?($_,$param{$_}):()}
965 qw(bug sourceversions arch dist version found fixed package)
967 if (defined $presence) {
968 if ($presence eq 'fixed') {
969 $status{pending} = 'done';
971 elsif ($presence eq 'absent') {
972 $status{pending} = 'absent';
980 my $precence = bug_presence(bug => nnn,
984 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
985 is found, absent, fixed, or no information is available in the
986 distribution (dist) and/or architecture (arch) specified.
993 =item bug -- scalar bug number
995 =item status -- optional hashref of bug status as returned by readbug
996 (can be passed to avoid rereading the bug information)
998 =item bug_index -- optional tied index of bug status infomration;
999 currently not correctly implemented.
1001 =item version -- optional version to check package status at
1003 =item dist -- optional distribution to check package status at
1005 =item arch -- optional architecture to check package status at
1007 =item sourceversion -- optional arrayref of source/version; overrides
1008 dist, arch, and version. [The entries in this array must be in the
1009 "source/version" format.] Eventually this can be used to for caching.
1016 my %param = validate_with(params => \@_,
1017 spec => {bug => {type => SCALAR,
1020 status => {type => HASHREF,
1023 version => {type => SCALAR|ARRAYREF,
1026 dist => {type => SCALAR|ARRAYREF,
1029 arch => {type => SCALAR|ARRAYREF,
1032 sourceversions => {type => ARRAYREF,
1038 if (defined $param{status}) {
1039 %status = %{$param{status}};
1042 my $location = getbuglocation($param{bug}, 'summary');
1043 return {} if not length $location;
1044 %status = %{ readbug( $param{bug}, $location ) };
1048 my $pseudo_desc = getpseudodesc();
1049 if (not exists $param{sourceversions}) {
1051 # pseudopackages do not have source versions by definition.
1052 if (exists $pseudo_desc->{$status{package}}) {
1055 elsif (defined $param{version}) {
1056 foreach my $arch (make_list($param{arch})) {
1057 for my $package (split /\s*,\s*/, $status{package}) {
1058 my @temp = makesourceversions($package,
1060 make_list($param{version})
1062 @sourceversions{@temp} = (1) x @temp;
1065 } elsif (defined $param{dist}) {
1066 foreach my $arch (make_list($param{arch})) {
1068 for my $package (split /\s*,\s*/, $status{package}) {
1069 foreach my $dist (make_list($param{dist})) {
1070 push @versions, getversions($package, $dist, $arch);
1072 my @temp = makesourceversions($package,
1076 @sourceversions{@temp} = (1) x @temp;
1081 # TODO: This should probably be handled further out for efficiency and
1082 # for more ease of distinguishing between pkg= and src= queries.
1083 # DLA: src= queries should just pass arch=source, and they'll be happy.
1084 @sourceversions = keys %sourceversions;
1087 @sourceversions = @{$param{sourceversions}};
1089 my $maxbuggy = 'undef';
1090 if (@sourceversions) {
1091 $maxbuggy = max_buggy(bug => $param{bug},
1092 sourceversions => \@sourceversions,
1093 found => $status{found_versions},
1094 fixed => $status{fixed_versions},
1095 package => $status{package},
1096 version_cache => $version_cache,
1099 elsif (defined $param{dist} and
1100 not exists $pseudo_desc->{$status{package}}) {
1103 if (length($status{done}) and
1104 (not @sourceversions or not @{$status{fixed_versions}})) {
1119 =item bug -- scalar bug number
1121 =item sourceversion -- optional arrayref of source/version; overrides
1122 dist, arch, and version. [The entries in this array must be in the
1123 "source/version" format.] Eventually this can be used to for caching.
1127 Note: Currently the version information is cached; this needs to be
1128 changed before using this function in long lived programs.
1133 my %param = validate_with(params => \@_,
1134 spec => {bug => {type => SCALAR,
1137 sourceversions => {type => ARRAYREF,
1140 found => {type => ARRAYREF,
1143 fixed => {type => ARRAYREF,
1146 package => {type => SCALAR,
1148 version_cache => {type => HASHREF,
1153 # Resolve bugginess states (we might be looking at multiple
1154 # architectures, say). Found wins, then fixed, then absent.
1155 my $maxbuggy = 'absent';
1156 for my $package (split /\s*,\s*/, $param{package}) {
1157 for my $version (@{$param{sourceversions}}) {
1158 my $buggy = buggy(bug => $param{bug},
1159 version => $version,
1160 found => $param{found},
1161 fixed => $param{fixed},
1162 version_cache => $param{version_cache},
1163 package => $package,
1165 if ($buggy eq 'found') {
1167 } elsif ($buggy eq 'fixed') {
1168 $maxbuggy = 'fixed';
1185 Returns the output of Debbugs::Versions::buggy for a particular
1186 package, version and found/fixed set. Automatically turns found, fixed
1187 and version into source/version strings.
1189 Caching can be had by using the version_cache, but no attempt to check
1190 to see if the on disk information is more recent than the cache is
1191 made. [This will need to be fixed for long-lived processes.]
1196 my %param = validate_with(params => \@_,
1197 spec => {bug => {type => SCALAR,
1200 found => {type => ARRAYREF,
1203 fixed => {type => ARRAYREF,
1206 version_cache => {type => HASHREF,
1209 package => {type => SCALAR,
1211 version => {type => SCALAR,
1215 my @found = @{$param{found}};
1216 my @fixed = @{$param{fixed}};
1217 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1218 # We have non-source version versions
1219 @found = makesourceversions($param{package},undef,
1222 @fixed = makesourceversions($param{package},undef,
1226 if ($param{version} !~ m{/}) {
1227 my ($version) = makesourceversions($param{package},undef,
1230 $param{version} = $version if defined $version;
1232 # Figure out which source packages we need
1234 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1235 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1236 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1237 $param{version} =~ m{/};
1239 if (not defined $param{version_cache} or
1240 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1241 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1242 foreach my $source (keys %sources) {
1243 my $srchash = substr $source, 0, 1;
1244 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1245 if (not defined $version_fh) {
1246 # We only want to warn if it's a package which actually has a maintainer
1247 my $maints = getmaintainers();
1248 next if not exists $maints->{$source};
1249 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1252 $version->load($version_fh);
1254 if (defined $param{version_cache}) {
1255 $param{version_cache}{join(',',sort keys %sources)} = $version;
1259 $version = $param{version_cache}{join(',',sort keys %sources)};
1261 return $version->buggy($param{version},\@found,\@fixed);
1264 sub isstrongseverity {
1265 my $severity = shift;
1266 $severity = $config{default_severity} if
1267 not defined $severity or $severity eq '';
1268 return grep { $_ eq $severity } @{$config{strong_severities}};
1272 =head1 PRIVATE FUNCTIONS
1276 sub update_realtime {
1277 my ($file, %bugs) = @_;
1279 # update realtime index.db
1281 return () unless keys %bugs;
1282 my $idx_old = IO::File->new($file,'r')
1283 or die "Couldn't open ${file}: $!";
1284 my $idx_new = IO::File->new($file.'.new','w')
1285 or die "Couldn't open ${file}.new: $!";
1287 my $min_bug = min(keys %bugs);
1291 while($line = <$idx_old>) {
1292 @line = split /\s/, $line;
1293 # Two cases; replacing existing line or adding new line
1294 if (exists $bugs{$line[1]}) {
1295 my $new = $bugs{$line[1]};
1296 delete $bugs{$line[1]};
1297 $min_bug = min(keys %bugs);
1298 if ($new eq "NOCHANGE") {
1299 print {$idx_new} $line;
1300 $changed_bugs{$line[1]} = $line;
1301 } elsif ($new eq "REMOVE") {
1302 $changed_bugs{$line[1]} = $line;
1304 print {$idx_new} $new;
1305 $changed_bugs{$line[1]} = $line;
1309 while ($line[1] > $min_bug) {
1310 print {$idx_new} $bugs{$min_bug};
1311 delete $bugs{$min_bug};
1312 last unless keys %bugs;
1313 $min_bug = min(keys %bugs);
1315 print {$idx_new} $line;
1317 last unless keys %bugs;
1319 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1321 print {$idx_new} <$idx_old>;
1326 rename("$file.new", $file);
1328 return %changed_bugs;
1331 sub bughook_archive {
1333 &filelock("$config{spool_dir}/debbugs.trace.lock");
1334 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1335 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1336 map{($_,'REMOVE')} @refs);
1337 update_realtime("$config{spool_dir}/index.archive.realtime",
1343 my ( $type, %bugs_temp ) = @_;
1344 &filelock("$config{spool_dir}/debbugs.trace.lock");
1347 for my $bug (keys %bugs_temp) {
1348 my $data = $bugs_temp{$bug};
1349 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1351 my $whendone = "open";
1352 my $severity = $config{default_severity};
1353 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1354 $pkglist =~ s/^,+//;
1355 $pkglist =~ s/,+$//;
1356 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1357 $whendone = "done" if defined $data->{done} and length $data->{done};
1358 $severity = $data->{severity} if length $data->{severity};
1360 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1361 $pkglist, $bug, $data->{date}, $whendone,
1362 $data->{originator}, $severity, $data->{keywords};
1365 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);