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',
103 summary => 'summary',
104 affects => 'affects',
107 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
108 my @rfc1522_fields = qw(originator subject done forwarded owner);
111 return read_bug(bug => $_[0],
112 (@_ > 1)?(location => $_[1]):()
118 read_bug(bug => $bug_num,
119 location => 'archive',
121 read_bug(summary => 'path/to/bugnum.summary');
124 A more complete function than readbug; it enables you to pass a full
125 path to the summary file instead of the bug number and/or location.
131 =item bug -- the bug number
133 =item location -- optional location which is passed to getbugcomponent
135 =item summary -- complete path to the .summary file which will be read
137 =item lock -- whether to obtain a lock for the bug to prevent
138 something modifying it while the bug has been read. You B<must> call
139 C<unfilelock();> if something not undef is returned from read_bug.
143 One of C<bug> or C<summary> must be passed. This function will return
144 undef on failure, and will die if improper arguments are passed.
152 my %param = validate_with(params => \@_,
153 spec => {bug => {type => SCALAR,
157 # negative bugnumbers
160 location => {type => SCALAR|UNDEF,
163 summary => {type => SCALAR,
166 lock => {type => BOOLEAN,
171 die "One of bug or summary must be passed to read_bug"
172 if not exists $param{bug} and not exists $param{summary};
176 if (not defined $param{summary}) {
178 ($lref,$location) = @param{qw(bug location)};
179 if (not defined $location) {
180 $location = getbuglocation($lref,'summary');
181 return undef if not defined $location;
183 $status = getbugcomponent($lref, 'summary', $location);
184 $log = getbugcomponent($lref, 'log' , $location);
185 return undef unless defined $status;
186 return undef if not -e $status;
189 $status = $param{summary};
191 $log =~ s/\.summary$/.log/;
192 ($location) = $status =~ m/(db-h|db|archive)/;
195 filelock("$config{spool_dir}/lock/$param{bug}");
197 my $status_fh = IO::File->new($status, 'r');
198 if (not defined $status_fh) {
199 warn "Unable to open $status for reading: $!";
211 while (<$status_fh>) {
214 $version = $1 if /^Format-Version: ([0-9]+)/i;
217 # Version 3 is the latest format version currently supported.
219 warn "Unsupported status version '$version'";
226 my %namemap = reverse %fields;
227 for my $line (@lines) {
228 if ($line =~ /(\S+?): (.*)/) {
229 my ($name, $value) = (lc $1, $2);
230 $data{$namemap{$name}} = $value if exists $namemap{$name};
233 for my $field (keys %fields) {
234 $data{$field} = '' unless exists $data{$field};
237 $data{severity} = $config{default_severity} if $data{severity} eq '';
238 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
239 $data{$field} = [split ' ', $data{$field}];
241 for my $field (qw(found fixed)) {
242 # create the found/fixed hashes which indicate when a
243 # particular version was marked found or marked fixed.
244 @{$data{$field}}{@{$data{"${field}_versions"}}} =
245 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
246 @{$data{"${field}_date"}});
250 for my $field (@rfc1522_fields) {
251 $data{$field} = decode_rfc1522($data{$field});
254 # Add log last modified time
255 $data{log_modified} = (stat($log))[9];
256 $data{location} = $location;
257 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
258 $data{bug_num} = $param{bug};
265 lockreadbug($bug_num,$location)
267 Performs a filelock, then reads the bug; the bug is unlocked if the
268 return is undefined, otherwise, you need to call unfilelock or
271 See readbug above for information on what this returns
276 my ($lref, $location) = @_;
277 return read_bug(bug => $lref, location => $location, lock => 1);
280 =head2 lockreadbugmerge
282 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
284 Performs a filelock, then reads the bug. If the bug is merged, locks
285 the merge lock. Returns a list of the number of locks and the bug
290 sub lockreadbugmerge {
291 my ($bug_num,$location) = @_;
292 my $data = lockreadbug(@_);
293 if (not defined $data) {
296 if (not length $data->{mergedwith}) {
300 filelock("$config{spool_dir}/lock/merge");
301 $data = lockreadbug(@_);
302 if (not defined $data) {
309 =head2 lock_read_all_merged_bugs
311 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
313 Performs a filelock, then reads the bug passed. If the bug is merged,
314 locks the merge lock, then reads and locks all of the other merged
315 bugs. Returns a list of the number of locks and the bug data for all
318 Will also return undef if any of the merged bugs failed to be read,
319 even if all of the others were read properly.
323 sub lock_read_all_merged_bugs {
324 my ($bug_num,$location) = @_;
326 my @data = (lockreadbug(@_));
327 if (not @data or not defined $data[0]) {
328 return ($locks,undef);
331 if (not length $data[0]->{mergedwith}) {
332 return ($locks,@data);
336 filelock("$config{spool_dir}/lock/merge");
338 @data = (lockreadbug(@_));
339 if (not @data or not defined $data[0]) {
340 unfilelock(); #for merge lock above
342 return ($locks,undef);
345 my @bugs = split / /, $data[0]->{mergedwith};
346 for my $bug (@bugs) {
348 if ($bug ne $bug_num) {
349 $newdata = lockreadbug($bug,$location);
350 if (not defined $newdata) {
355 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
356 return ($locks,undef);
361 # perform a sanity check to make sure that the merged bugs are
362 # all merged with eachother
363 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
364 if ($newdata->{mergedwith} ne $expectmerge) {
368 die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
371 return ($locks,@data);
375 my @v1fieldorder = qw(originator date subject msgid package
376 keywords done forwarded mergedwith severity);
380 my $content = makestatus($status,$version)
381 my $content = makestatus($status);
383 Creates the content for a status file based on the $status hashref
386 Really only useful for writebug
388 Currently defaults to version 2 (non-encoded rfc1522 names) but will
389 eventually default to version 3. If you care, you should specify a
395 my ($data,$version) = @_;
396 $version = 2 unless defined $version;
400 my %newdata = %$data;
401 for my $field (qw(found fixed)) {
402 if (exists $newdata{$field}) {
403 $newdata{"${field}_date"} =
404 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
408 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
409 $newdata{$field} = join ' ', @{$newdata{$field}||[]};
413 for my $field (@rfc1522_fields) {
414 $newdata{$field} = encode_rfc1522($newdata{$field});
419 for my $field (@v1fieldorder) {
420 if (exists $newdata{$field} and defined $newdata{$field}) {
421 $contents .= "$newdata{$field}\n";
426 } elsif ($version == 2 or $version == 3) {
427 # Version 2 or 3. Add a file format version number for the sake of
428 # further extensibility in the future.
429 $contents .= "Format-Version: $version\n";
430 for my $field (keys %fields) {
431 if (exists $newdata{$field} and defined $newdata{$field}
432 and $newdata{$field} ne '') {
433 # Output field names in proper case, e.g. 'Merged-With'.
434 my $properfield = $fields{$field};
435 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
436 $contents .= "$properfield: $newdata{$field}\n";
446 writebug($bug_num,$status,$location,$minversion,$disablebughook)
448 Writes the bug status and summary files out.
450 Skips writting out a status file if minversion is 2
452 Does not call bughook if disablebughook is true.
457 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
460 my %outputs = (1 => 'status', 2 => 'summary');
461 for my $version (keys %outputs) {
462 next if defined $minversion and $version < $minversion;
463 my $status = getbugcomponent($ref, $outputs{$version}, $location);
464 die "can't find location for $ref" unless defined $status;
465 open(S,"> $status.new") || die "opening $status.new: $!";
466 print(S makestatus($data, $version)) ||
467 die "writing $status.new: $!";
468 close(S) || die "closing $status.new: $!";
474 rename("$status.new",$status) || die "installing new $status: $!";
477 # $disablebughook is a bit of a hack to let format migration scripts use
478 # this function rather than having to duplicate it themselves.
479 &bughook($change,$ref,$data) unless $disablebughook;
482 =head2 unlockwritebug
484 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
486 Writes a bug, then calls unfilelock; see writebug for what these
498 The following functions are exported with the :versions tag
500 =head2 addfoundversions
502 addfoundversions($status,$package,$version,$isbinary);
509 sub addfoundversions {
513 my $isbinary = shift;
514 return unless defined $version;
515 undef $package if $package =~ m[(?:\s|/)];
516 my $source = $package;
518 if (defined $package and $isbinary) {
519 my @srcinfo = binarytosource($package, $version, undef);
521 # We know the source package(s). Use a fully-qualified version.
522 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
525 # Otherwise, an unqualified version will have to do.
529 # Strip off various kinds of brain-damage.
531 $version =~ s/ *\(.*\)//;
532 $version =~ s/ +[A-Za-z].*//;
534 foreach my $ver (split /[,\s]+/, $version) {
535 my $sver = defined($source) ? "$source/$ver" : '';
536 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
537 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
539 @{$data->{fixed_versions}} =
540 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
544 =head2 removefoundversions
546 removefoundversions($data,$package,$versiontoremove)
548 Removes found versions from $data
550 If a version is fully qualified (contains /) only versions matching
551 exactly are removed. Otherwise, all versions matching the version
554 Currently $package and $isbinary are entirely ignored, but accepted
555 for backwards compatibilty.
559 sub removefoundversions {
563 my $isbinary = shift;
564 return unless defined $version;
566 foreach my $ver (split /[,\s]+/, $version) {
568 # fully qualified version
569 @{$data->{found_versions}} =
571 @{$data->{found_versions}};
574 # non qualified version; delete all matchers
575 @{$data->{found_versions}} =
576 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
577 @{$data->{found_versions}};
583 sub addfixedversions {
587 my $isbinary = shift;
588 return unless defined $version;
589 undef $package if defined $package and $package =~ m[(?:\s|/)];
590 my $source = $package;
592 if (defined $package and $isbinary) {
593 my @srcinfo = binarytosource($package, $version, undef);
595 # We know the source package(s). Use a fully-qualified version.
596 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
599 # Otherwise, an unqualified version will have to do.
603 # Strip off various kinds of brain-damage.
605 $version =~ s/ *\(.*\)//;
606 $version =~ s/ +[A-Za-z].*//;
608 foreach my $ver (split /[,\s]+/, $version) {
609 my $sver = defined($source) ? "$source/$ver" : '';
610 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
611 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
613 @{$data->{found_versions}} =
614 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
618 sub removefixedversions {
622 my $isbinary = shift;
623 return unless defined $version;
625 foreach my $ver (split /[,\s]+/, $version) {
627 # fully qualified version
628 @{$data->{fixed_versions}} =
630 @{$data->{fixed_versions}};
633 # non qualified version; delete all matchers
634 @{$data->{fixed_versions}} =
635 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
636 @{$data->{fixed_versions}};
647 Split a package string from the status file into a list of package names.
653 return unless defined $pkgs;
654 return map lc, split /[ \t?,()]+/, $pkgs;
658 =head2 bug_archiveable
660 bug_archiveable(bug => $bug_num);
666 =item bug -- bug number (required)
668 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
670 =item version -- Debbugs::Version information (optional)
672 =item days_until -- return days until the bug can be archived
676 Returns 1 if the bug can be archived
677 Returns 0 if the bug cannot be archived
679 If days_until is true, returns the number of days until the bug can be
680 archived, -1 if it cannot be archived. 0 means that the bug can be
681 archived the next time the archiver runs.
683 Returns undef on failure.
687 # This will eventually need to be fixed before we start using mod_perl
688 our $version_cache = {};
690 my %param = validate_with(params => \@_,
691 spec => {bug => {type => SCALAR,
694 status => {type => HASHREF,
697 days_until => {type => BOOLEAN,
700 ignore_time => {type => BOOLEAN,
705 # This is what we return if the bug cannot be archived.
706 my $cannot_archive = $param{days_until}?-1:0;
707 # read the status information
708 my $status = $param{status};
709 if (not exists $param{status} or not defined $status) {
710 $status = read_bug(bug=>$param{bug});
711 if (not defined $status) {
712 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
716 # Bugs can be archived if they are
718 if (not defined $status->{done} or not length $status->{done}) {
719 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
720 return $cannot_archive
722 # Check to make sure that the bug has none of the unremovable tags set
723 if (@{$config{removal_unremovable_tags}}) {
724 for my $tag (split ' ', ($status->{tags}||'')) {
725 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
726 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
727 return $cannot_archive;
732 # If we just are checking if the bug can be archived, we'll not even bother
733 # checking the versioning information if the bug has been -done for less than 28 days.
734 my $log_file = getbugcomponent($param{bug},'log');
735 if (not defined $log_file) {
736 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
737 return $cannot_archive;
739 my $max_log_age = max(map {$config{remove_age} - -M $_}
740 $log_file, map {my $log = getbugcomponent($_,'log');
741 defined $log ? ($log) : ();
743 split / /, $status->{mergedwith}
745 if (not $param{days_until} and not $param{ignore_time}
748 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
749 return $cannot_archive;
751 # At this point, we have to get the versioning information for this bug.
752 # We examine the set of distribution tags. If a bug has no distribution
753 # tags set, we assume a default set, otherwise we use the tags the bug
756 # In cases where we are assuming a default set, if the severity
757 # is strong, we use the strong severity default; otherwise, we
758 # use the normal default.
760 # There must be fixed_versions for us to look at the versioning
762 my $min_fixed_time = time;
763 my $min_archive_days = 0;
764 if (@{$status->{fixed_versions}}) {
766 @dist_tags{@{$config{removal_distribution_tags}}} =
767 (1) x @{$config{removal_distribution_tags}};
769 for my $tag (split ' ', ($status->{tags}||'')) {
770 next unless exists $config{distribution_aliases}{$tag};
771 next unless $dist_tags{$config{distribution_aliases}{$tag}};
772 $dists{$config{distribution_aliases}{$tag}} = 1;
774 if (not keys %dists) {
775 if (isstrongseverity($status->{severity})) {
776 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
777 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
780 @dists{@{$config{removal_default_distribution_tags}}} =
781 (1) x @{$config{removal_default_distribution_tags}};
785 my @sourceversions = get_versions(package => $status->{package},
786 dist => [keys %dists],
789 @source_versions{@sourceversions} = (1) x @sourceversions;
790 # If the bug has not been fixed in the versions actually
791 # distributed, then it cannot be archived.
792 if ('found' eq max_buggy(bug => $param{bug},
793 sourceversions => [keys %source_versions],
794 found => $status->{found_versions},
795 fixed => $status->{fixed_versions},
796 version_cache => $version_cache,
797 package => $status->{package},
799 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
800 return $cannot_archive;
802 # Since the bug has at least been fixed in the architectures
803 # that matters, we check to see how long it has been fixed.
805 # If $param{ignore_time}, then we should ignore time.
806 if ($param{ignore_time}) {
807 return $param{days_until}?0:1;
810 # To do this, we order the times from most recent to oldest;
811 # when we come to the first found version, we stop.
812 # If we run out of versions, we only report the time of the
814 my %time_versions = get_versions(package => $status->{package},
815 dist => [keys %dists],
819 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
820 my $buggy = buggy(bug => $param{bug},
822 found => $status->{found_versions},
823 fixed => $status->{fixed_versions},
824 version_cache => $version_cache,
825 package => $status->{package},
827 last if $buggy eq 'found';
828 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
830 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
831 # if there are no versions in the archive at all, then
832 # we can archive if enough days have passed
835 # If $param{ignore_time}, then we should ignore time.
836 if ($param{ignore_time}) {
837 return $param{days_until}?0:1;
839 # 6. at least 28 days have passed since the last action has occured or the bug was closed
840 my $age = ceil($max_log_age);
841 if ($age > 0 or $min_archive_days > 0) {
842 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
843 return $param{days_until}?max($age,$min_archive_days):0;
846 return $param{days_until}?0:1;
851 =head2 get_bug_status
853 my $status = get_bug_status(bug => $nnn);
855 my $status = get_bug_status($bug_num)
861 =item bug -- scalar bug number
863 =item status -- optional hashref of bug status as returned by readbug
864 (can be passed to avoid rereading the bug information)
866 =item bug_index -- optional tied index of bug status infomration;
867 currently not correctly implemented.
869 =item version -- optional version(s) to check package status at
871 =item dist -- optional distribution(s) to check package status at
873 =item arch -- optional architecture(s) to check package status at
875 =item bugusertags -- optional hashref of bugusertags
877 =item sourceversion -- optional arrayref of source/version; overrides
878 dist, arch, and version. [The entries in this array must be in the
879 "source/version" format.] Eventually this can be used to for caching.
881 =item indicatesource -- if true, indicate which source packages this
882 bug could belong to (or does belong to in the case of bugs assigned to
883 a source package). Defaults to true.
887 Note: Currently the version information is cached; this needs to be
888 changed before using this function in long lived programs.
896 my %param = validate_with(params => \@_,
897 spec => {bug => {type => SCALAR,
900 status => {type => HASHREF,
903 bug_index => {type => OBJECT,
906 version => {type => SCALAR|ARRAYREF,
909 dist => {type => SCALAR|ARRAYREF,
912 arch => {type => SCALAR|ARRAYREF,
915 bugusertags => {type => HASHREF,
918 sourceversions => {type => ARRAYREF,
921 indicatesource => {type => BOOLEAN,
928 if (defined $param{bug_index} and
929 exists $param{bug_index}{$param{bug}}) {
930 %status = %{ $param{bug_index}{$param{bug}} };
931 $status{pending} = $status{ status };
932 $status{id} = $param{bug};
935 if (defined $param{status}) {
936 %status = %{$param{status}};
939 my $location = getbuglocation($param{bug}, 'summary');
940 return {} if not defined $location or not length $location;
941 %status = %{ readbug( $param{bug}, $location ) };
943 $status{id} = $param{bug};
945 if (defined $param{bugusertags}{$param{bug}}) {
946 $status{keywords} = "" unless defined $status{keywords};
947 $status{keywords} .= " " unless $status{keywords} eq "";
948 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
950 $status{tags} = $status{keywords};
951 my %tags = map { $_ => 1 } split ' ', $status{tags};
953 $status{package} = '' if not defined $status{package};
954 $status{"package"} =~ s/\s*$//;
955 # if we aren't supposed to indicate the source, we'll return
957 $status{source} = 'unknown';
958 if ($param{indicatesource}) {
959 my @packages = split /\s*,\s*/, $status{package};
961 for my $package (@packages) {
962 next if $package eq '';
963 if ($package =~ /^src\:$/) {
967 push @source, binarytosource($package);
971 $status{source} = join(', ',@source);
975 $status{"package"} = 'unknown' if ($status{"package"} eq '');
976 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
978 $status{"pending"} = 'pending';
979 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
980 $status{"pending"} = 'pending-fixed' if ($tags{pending});
981 $status{"pending"} = 'fixed' if ($tags{fixed});
984 my $presence = bug_presence(status => \%status,
985 map{(exists $param{$_})?($_,$param{$_}):()}
986 qw(bug sourceversions arch dist version found fixed package)
988 if (defined $presence) {
989 if ($presence eq 'fixed') {
990 $status{pending} = 'done';
992 elsif ($presence eq 'absent') {
993 $status{pending} = 'absent';
1001 my $precence = bug_presence(bug => nnn,
1005 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1006 is found, absent, fixed, or no information is available in the
1007 distribution (dist) and/or architecture (arch) specified.
1014 =item bug -- scalar bug number
1016 =item status -- optional hashref of bug status as returned by readbug
1017 (can be passed to avoid rereading the bug information)
1019 =item bug_index -- optional tied index of bug status infomration;
1020 currently not correctly implemented.
1022 =item version -- optional version to check package status at
1024 =item dist -- optional distribution to check package status at
1026 =item arch -- optional architecture to check package status at
1028 =item sourceversion -- optional arrayref of source/version; overrides
1029 dist, arch, and version. [The entries in this array must be in the
1030 "source/version" format.] Eventually this can be used to for caching.
1037 my %param = validate_with(params => \@_,
1038 spec => {bug => {type => SCALAR,
1041 status => {type => HASHREF,
1044 version => {type => SCALAR|ARRAYREF,
1047 dist => {type => SCALAR|ARRAYREF,
1050 arch => {type => SCALAR|ARRAYREF,
1053 sourceversions => {type => ARRAYREF,
1059 if (defined $param{status}) {
1060 %status = %{$param{status}};
1063 my $location = getbuglocation($param{bug}, 'summary');
1064 return {} if not length $location;
1065 %status = %{ readbug( $param{bug}, $location ) };
1069 my $pseudo_desc = getpseudodesc();
1070 if (not exists $param{sourceversions}) {
1072 # pseudopackages do not have source versions by definition.
1073 if (exists $pseudo_desc->{$status{package}}) {
1076 elsif (defined $param{version}) {
1077 foreach my $arch (make_list($param{arch})) {
1078 for my $package (split /\s*,\s*/, $status{package}) {
1079 my @temp = makesourceversions($package,
1081 make_list($param{version})
1083 @sourceversions{@temp} = (1) x @temp;
1086 } elsif (defined $param{dist}) {
1087 my %affects_distribution_tags;
1088 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1089 (1) x @{$config{affects_distribution_tags}};
1090 my $some_distributions_disallowed = 0;
1091 my %allowed_distributions;
1092 for my $tag (split ' ', ($status{tags}||'')) {
1093 if (exists $config{distribution_aliases}{$tag} and
1094 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1095 $some_distributions_disallowed = 1;
1096 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1098 elsif (exists $affects_distribution_tags{$tag}) {
1099 $some_distributions_disallowed = 1;
1100 $allowed_distributions{$tag} = 1;
1103 foreach my $arch (make_list($param{arch})) {
1104 for my $package (split /\s*,\s*/, $status{package}) {
1106 foreach my $dist (make_list($param{dist})) {
1107 # if some distributions are disallowed,
1108 # and this isn't an allowed
1109 # distribution, then we ignore this
1110 # distribution for the purposees of
1112 if ($some_distributions_disallowed and
1113 not exists $allowed_distributions{$dist}) {
1116 push @versions, getversions($package, $dist, $arch);
1118 next unless @versions;
1119 my @temp = makesourceversions($package,
1123 @sourceversions{@temp} = (1) x @temp;
1128 # TODO: This should probably be handled further out for efficiency and
1129 # for more ease of distinguishing between pkg= and src= queries.
1130 # DLA: src= queries should just pass arch=source, and they'll be happy.
1131 @sourceversions = keys %sourceversions;
1134 @sourceversions = @{$param{sourceversions}};
1136 my $maxbuggy = 'undef';
1137 if (@sourceversions) {
1138 $maxbuggy = max_buggy(bug => $param{bug},
1139 sourceversions => \@sourceversions,
1140 found => $status{found_versions},
1141 fixed => $status{fixed_versions},
1142 package => $status{package},
1143 version_cache => $version_cache,
1146 elsif (defined $param{dist} and
1147 not exists $pseudo_desc->{$status{package}}) {
1150 if (length($status{done}) and
1151 (not @sourceversions or not @{$status{fixed_versions}})) {
1166 =item bug -- scalar bug number
1168 =item sourceversion -- optional arrayref of source/version; overrides
1169 dist, arch, and version. [The entries in this array must be in the
1170 "source/version" format.] Eventually this can be used to for caching.
1174 Note: Currently the version information is cached; this needs to be
1175 changed before using this function in long lived programs.
1180 my %param = validate_with(params => \@_,
1181 spec => {bug => {type => SCALAR,
1184 sourceversions => {type => ARRAYREF,
1187 found => {type => ARRAYREF,
1190 fixed => {type => ARRAYREF,
1193 package => {type => SCALAR,
1195 version_cache => {type => HASHREF,
1200 # Resolve bugginess states (we might be looking at multiple
1201 # architectures, say). Found wins, then fixed, then absent.
1202 my $maxbuggy = 'absent';
1203 for my $package (split /\s*,\s*/, $param{package}) {
1204 for my $version (@{$param{sourceversions}}) {
1205 my $buggy = buggy(bug => $param{bug},
1206 version => $version,
1207 found => $param{found},
1208 fixed => $param{fixed},
1209 version_cache => $param{version_cache},
1210 package => $package,
1212 if ($buggy eq 'found') {
1214 } elsif ($buggy eq 'fixed') {
1215 $maxbuggy = 'fixed';
1232 Returns the output of Debbugs::Versions::buggy for a particular
1233 package, version and found/fixed set. Automatically turns found, fixed
1234 and version into source/version strings.
1236 Caching can be had by using the version_cache, but no attempt to check
1237 to see if the on disk information is more recent than the cache is
1238 made. [This will need to be fixed for long-lived processes.]
1243 my %param = validate_with(params => \@_,
1244 spec => {bug => {type => SCALAR,
1247 found => {type => ARRAYREF,
1250 fixed => {type => ARRAYREF,
1253 version_cache => {type => HASHREF,
1256 package => {type => SCALAR,
1258 version => {type => SCALAR,
1262 my @found = @{$param{found}};
1263 my @fixed = @{$param{fixed}};
1264 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1265 # We have non-source version versions
1266 @found = makesourceversions($param{package},undef,
1269 @fixed = makesourceversions($param{package},undef,
1273 if ($param{version} !~ m{/}) {
1274 my ($version) = makesourceversions($param{package},undef,
1277 $param{version} = $version if defined $version;
1279 # Figure out which source packages we need
1281 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1282 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1283 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1284 $param{version} =~ m{/};
1286 if (not defined $param{version_cache} or
1287 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1288 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1289 foreach my $source (keys %sources) {
1290 my $srchash = substr $source, 0, 1;
1291 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1292 if (not defined $version_fh) {
1293 # We only want to warn if it's a package which actually has a maintainer
1294 my $maints = getmaintainers();
1295 next if not exists $maints->{$source};
1296 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1299 $version->load($version_fh);
1301 if (defined $param{version_cache}) {
1302 $param{version_cache}{join(',',sort keys %sources)} = $version;
1306 $version = $param{version_cache}{join(',',sort keys %sources)};
1308 return $version->buggy($param{version},\@found,\@fixed);
1311 sub isstrongseverity {
1312 my $severity = shift;
1313 $severity = $config{default_severity} if
1314 not defined $severity or $severity eq '';
1315 return grep { $_ eq $severity } @{$config{strong_severities}};
1319 =head1 PRIVATE FUNCTIONS
1323 sub update_realtime {
1324 my ($file, %bugs) = @_;
1326 # update realtime index.db
1328 return () unless keys %bugs;
1329 my $idx_old = IO::File->new($file,'r')
1330 or die "Couldn't open ${file}: $!";
1331 my $idx_new = IO::File->new($file.'.new','w')
1332 or die "Couldn't open ${file}.new: $!";
1334 my $min_bug = min(keys %bugs);
1338 while($line = <$idx_old>) {
1339 @line = split /\s/, $line;
1340 # Two cases; replacing existing line or adding new line
1341 if (exists $bugs{$line[1]}) {
1342 my $new = $bugs{$line[1]};
1343 delete $bugs{$line[1]};
1344 $min_bug = min(keys %bugs);
1345 if ($new eq "NOCHANGE") {
1346 print {$idx_new} $line;
1347 $changed_bugs{$line[1]} = $line;
1348 } elsif ($new eq "REMOVE") {
1349 $changed_bugs{$line[1]} = $line;
1351 print {$idx_new} $new;
1352 $changed_bugs{$line[1]} = $line;
1356 while ($line[1] > $min_bug) {
1357 print {$idx_new} $bugs{$min_bug};
1358 delete $bugs{$min_bug};
1359 last unless keys %bugs;
1360 $min_bug = min(keys %bugs);
1362 print {$idx_new} $line;
1364 last unless keys %bugs;
1366 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1368 print {$idx_new} <$idx_old>;
1373 rename("$file.new", $file);
1375 return %changed_bugs;
1378 sub bughook_archive {
1380 &filelock("$config{spool_dir}/debbugs.trace.lock");
1381 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1382 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1383 map{($_,'REMOVE')} @refs);
1384 update_realtime("$config{spool_dir}/index.archive.realtime",
1390 my ( $type, %bugs_temp ) = @_;
1391 &filelock("$config{spool_dir}/debbugs.trace.lock");
1394 for my $bug (keys %bugs_temp) {
1395 my $data = $bugs_temp{$bug};
1396 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1398 my $whendone = "open";
1399 my $severity = $config{default_severity};
1400 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1401 $pkglist =~ s/^,+//;
1402 $pkglist =~ s/,+$//;
1403 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1404 $whendone = "done" if defined $data->{done} and length $data->{done};
1405 $severity = $data->{severity} if length $data->{severity};
1407 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1408 $pkglist, $bug, $data->{date}, $whendone,
1409 $data->{originator}, $severity, $data->{keywords};
1412 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);