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-9 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Status;
14 Debbugs::Status -- Routines for dealing with summary and status files
23 This module is a replacement for the parts of errorlib.pl which write
24 and read status and summary files.
26 It also contains generic routines for returning information about the
27 status of a particular bug
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(:util :lock :quit :misc);
41 use Debbugs::Config qw(:config);
42 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
43 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
44 use Debbugs::Versions;
45 use Debbugs::Versions::Dpkg;
48 use Storable qw(dclone);
49 use List::Util qw(min max);
55 $DEBUG = 0 unless defined $DEBUG;
58 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
59 qw(isstrongseverity bug_presence split_status_fields),
61 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
62 qw(lock_read_all_merged_bugs),
64 write => [qw(writebug makestatus unlockwritebug)],
65 versions => [qw(addfoundversions addfixedversions),
66 qw(removefoundversions removefixedversions)
68 hook => [qw(bughook bughook_archive)],
69 fields => [qw(%fields)],
72 Exporter::export_ok_tags(qw(status read write versions hook fields));
73 $EXPORT_TAGS{all} = [@EXPORT_OK];
79 readbug($bug_num,$location)
82 Reads a summary file from the archive given a bug number and a bug
83 location. Valid locations are those understood by L</getbugcomponent>
87 # these probably shouldn't be imported by most people, but
88 # Debbugs::Control needs them, so they're now exportable
89 our %fields = (originator => 'submitter',
92 msgid => 'message-id',
93 'package' => 'package',
96 forwarded => 'forwarded-to',
97 mergedwith => 'merged-with',
98 severity => 'severity',
100 found_versions => 'found-in',
101 found_date => 'found-date',
102 fixed_versions => 'fixed-in',
103 fixed_date => 'fixed-date',
105 blockedby => 'blocked-by',
106 unarchived => 'unarchived',
107 summary => 'summary',
108 affects => 'affects',
112 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
113 my @rfc1522_fields = qw(originator subject done forwarded owner);
116 return read_bug(bug => $_[0],
117 (@_ > 1)?(location => $_[1]):()
123 read_bug(bug => $bug_num,
124 location => 'archive',
126 read_bug(summary => 'path/to/bugnum.summary');
129 A more complete function than readbug; it enables you to pass a full
130 path to the summary file instead of the bug number and/or location.
136 =item bug -- the bug number
138 =item location -- optional location which is passed to getbugcomponent
140 =item summary -- complete path to the .summary file which will be read
142 =item lock -- whether to obtain a lock for the bug to prevent
143 something modifying it while the bug has been read. You B<must> call
144 C<unfilelock();> if something not undef is returned from read_bug.
148 One of C<bug> or C<summary> must be passed. This function will return
149 undef on failure, and will die if improper arguments are passed.
157 my %param = validate_with(params => \@_,
158 spec => {bug => {type => SCALAR,
162 # negative bugnumbers
165 location => {type => SCALAR|UNDEF,
168 summary => {type => SCALAR,
171 lock => {type => BOOLEAN,
176 die "One of bug or summary must be passed to read_bug"
177 if not exists $param{bug} and not exists $param{summary};
181 if (not defined $param{summary}) {
183 ($lref,$location) = @param{qw(bug location)};
184 if (not defined $location) {
185 $location = getbuglocation($lref,'summary');
186 return undef if not defined $location;
188 $status = getbugcomponent($lref, 'summary', $location);
189 $log = getbugcomponent($lref, 'log' , $location);
190 return undef unless defined $status;
191 return undef if not -e $status;
194 $status = $param{summary};
196 $log =~ s/\.summary$/.log/;
197 ($location) = $status =~ m/(db-h|db|archive)/;
200 filelock("$config{spool_dir}/lock/$param{bug}");
202 my $status_fh = IO::File->new($status, 'r');
203 if (not defined $status_fh) {
204 warn "Unable to open $status for reading: $!";
216 while (<$status_fh>) {
219 $version = $1 if /^Format-Version: ([0-9]+)/i;
222 # Version 3 is the latest format version currently supported.
224 warn "Unsupported status version '$version'";
231 my %namemap = reverse %fields;
232 for my $line (@lines) {
233 if ($line =~ /(\S+?): (.*)/) {
234 my ($name, $value) = (lc $1, $2);
235 # this is a bit of a hack; we should never, ever have \r
236 # or \n in the fields of status. Kill them off here.
237 # [Eventually, this should be superfluous.]
238 $value =~ s/[\r\n]//g;
239 $data{$namemap{$name}} = $value if exists $namemap{$name};
242 for my $field (keys %fields) {
243 $data{$field} = '' unless exists $data{$field};
246 $data{severity} = $config{default_severity} if $data{severity} eq '';
247 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
248 $data{$field} = [split ' ', $data{$field}];
250 for my $field (qw(found fixed)) {
251 # create the found/fixed hashes which indicate when a
252 # particular version was marked found or marked fixed.
253 @{$data{$field}}{@{$data{"${field}_versions"}}} =
254 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
255 @{$data{"${field}_date"}});
259 for my $field (@rfc1522_fields) {
260 $data{$field} = decode_rfc1522($data{$field});
263 my $status_modified = (stat($status))[9];
264 # Add log last modified time
265 $data{log_modified} = (stat($log))[9];
266 $data{last_modified} = max($status_modified,$data{log_modified});
267 $data{location} = $location;
268 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
269 $data{bug_num} = $param{bug};
274 =head2 split_status_fields
276 my @data = split_status_fields(@data);
278 Splits splittable status fields (like package, tags, blocks,
279 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
280 passed @data intact using dclone.
282 In scalar context, returns only the first element of @data.
286 our $ditch_empty = sub{
288 my $splitter = shift @t;
289 return grep {length $_} map {split $splitter} @t;
292 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
294 (package => \&splitpackages,
295 affects => \&splitpackages,
296 blocks => $ditch_empty_space,
297 blockedby => $ditch_empty_space,
298 # this isn't strictly correct, but we'll split both of them for
299 # the time being until we ditch all use of keywords everywhere
301 keywords => $ditch_empty_space,
302 tags => $ditch_empty_space,
303 found_versions => $ditch_empty_space,
304 fixed_versions => $ditch_empty_space,
305 mergedwith => $ditch_empty_space,
308 sub split_status_fields {
309 my @data = @{dclone(\@_)};
310 for my $data (@data) {
311 next if not defined $data;
312 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
313 not (ref($data) and ref($data) eq 'HASH');
314 for my $field (keys %{$data}) {
315 next unless defined $data->{$field};
316 if (exists $split_fields{$field}) {
317 next if ref($data->{$field});
319 if (ref($split_fields{$field}) eq 'CODE') {
320 @elements = &{$split_fields{$field}}($data->{$field});
322 elsif (not ref($split_fields{$field}) or
323 UNIVERSAL::isa($split_fields{$field},'Regex')
325 @elements = split $split_fields{$field}, $data->{$field};
327 $data->{$field} = \@elements;
331 return wantarray?@data:$data[0];
334 =head2 join_status_fields
336 my @data = join_status_fields(@data);
338 Handles joining the splitable status fields. (Basically, the inverse
339 of split_status_fields.
341 Primarily called from makestatus, but may be useful for other
342 functions after calling split_status_fields (or for legacy functions
343 if we transition to split fields by default).
347 sub join_status_fields {
354 found_versions => ' ',
355 fixed_versions => ' ',
360 my @data = @{dclone(\@_)};
361 for my $data (@data) {
362 next if not defined $data;
363 croak "Passed an element which is not a hashref to split_status_field: ".
365 if ref($data) ne 'HASH';
366 for my $field (keys %{$data}) {
367 next unless defined $data->{$field};
368 next unless ref($data->{$field}) eq 'ARRAY';
369 next unless exists $join_fields{$field};
370 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
373 return wantarray?@data:$data[0];
379 lockreadbug($bug_num,$location)
381 Performs a filelock, then reads the bug; the bug is unlocked if the
382 return is undefined, otherwise, you need to call unfilelock or
385 See readbug above for information on what this returns
390 my ($lref, $location) = @_;
391 return read_bug(bug => $lref, location => $location, lock => 1);
394 =head2 lockreadbugmerge
396 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
398 Performs a filelock, then reads the bug. If the bug is merged, locks
399 the merge lock. Returns a list of the number of locks and the bug
404 sub lockreadbugmerge {
405 my ($bug_num,$location) = @_;
406 my $data = lockreadbug(@_);
407 if (not defined $data) {
410 if (not length $data->{mergedwith}) {
414 filelock("$config{spool_dir}/lock/merge");
415 $data = lockreadbug(@_);
416 if (not defined $data) {
423 =head2 lock_read_all_merged_bugs
425 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
427 Performs a filelock, then reads the bug passed. If the bug is merged,
428 locks the merge lock, then reads and locks all of the other merged
429 bugs. Returns a list of the number of locks and the bug data for all
432 Will also return undef if any of the merged bugs failed to be read,
433 even if all of the others were read properly.
437 sub lock_read_all_merged_bugs {
438 my ($bug_num,$location) = @_;
440 my @data = (lockreadbug(@_));
441 if (not @data or not defined $data[0]) {
445 if (not length $data[0]->{mergedwith}) {
446 return ($locks,@data);
450 filelock("$config{spool_dir}/lock/merge");
452 @data = (lockreadbug(@_));
453 if (not @data or not defined $data[0]) {
454 unfilelock(); #for merge lock above
459 my @bugs = split / /, $data[0]->{mergedwith};
460 for my $bug (@bugs) {
462 if ($bug ne $bug_num) {
463 $newdata = lockreadbug($bug,$location);
464 if (not defined $newdata) {
469 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
475 # perform a sanity check to make sure that the merged bugs are
476 # all merged with eachother
477 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
478 if ($newdata->{mergedwith} ne $expectmerge) {
482 die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
485 return ($locks,@data);
489 my @v1fieldorder = qw(originator date subject msgid package
490 keywords done forwarded mergedwith severity);
494 my $content = makestatus($status,$version)
495 my $content = makestatus($status);
497 Creates the content for a status file based on the $status hashref
500 Really only useful for writebug
502 Currently defaults to version 2 (non-encoded rfc1522 names) but will
503 eventually default to version 3. If you care, you should specify a
509 my ($data,$version) = @_;
510 $version = 2 unless defined $version;
514 my %newdata = %$data;
515 for my $field (qw(found fixed)) {
516 if (exists $newdata{$field}) {
517 $newdata{"${field}_date"} =
518 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
521 %newdata = %{join_status_fields(\%newdata)};
524 for my $field (@rfc1522_fields) {
525 $newdata{$field} = encode_rfc1522($newdata{$field});
529 # this is a bit of a hack; we should never, ever have \r or \n in
530 # the fields of status. Kill them off here. [Eventually, this
531 # should be superfluous.]
532 for my $field (keys %newdata) {
533 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
537 for my $field (@v1fieldorder) {
538 if (exists $newdata{$field} and defined $newdata{$field}) {
539 $contents .= "$newdata{$field}\n";
544 } elsif ($version == 2 or $version == 3) {
545 # Version 2 or 3. Add a file format version number for the sake of
546 # further extensibility in the future.
547 $contents .= "Format-Version: $version\n";
548 for my $field (keys %fields) {
549 if (exists $newdata{$field} and defined $newdata{$field}
550 and $newdata{$field} ne '') {
551 # Output field names in proper case, e.g. 'Merged-With'.
552 my $properfield = $fields{$field};
553 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
554 $contents .= "$properfield: $newdata{$field}\n";
564 writebug($bug_num,$status,$location,$minversion,$disablebughook)
566 Writes the bug status and summary files out.
568 Skips writting out a status file if minversion is 2
570 Does not call bughook if disablebughook is true.
575 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
578 my %outputs = (1 => 'status', 2 => 'summary');
579 for my $version (keys %outputs) {
580 next if defined $minversion and $version < $minversion;
581 my $status = getbugcomponent($ref, $outputs{$version}, $location);
582 die "can't find location for $ref" unless defined $status;
583 open(S,"> $status.new") || die "opening $status.new: $!";
584 print(S makestatus($data, $version)) ||
585 die "writing $status.new: $!";
586 close(S) || die "closing $status.new: $!";
592 rename("$status.new",$status) || die "installing new $status: $!";
595 # $disablebughook is a bit of a hack to let format migration scripts use
596 # this function rather than having to duplicate it themselves.
597 &bughook($change,$ref,$data) unless $disablebughook;
600 =head2 unlockwritebug
602 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
604 Writes a bug, then calls unfilelock; see writebug for what these
616 The following functions are exported with the :versions tag
618 =head2 addfoundversions
620 addfoundversions($status,$package,$version,$isbinary);
622 All use of this should be phased out in favor of Debbugs::Control::fixed/found
627 sub addfoundversions {
631 my $isbinary = shift;
632 return unless defined $version;
633 undef $package if $package =~ m[(?:\s|/)];
634 my $source = $package;
635 if ($package =~ s/^src://) {
640 if (defined $package and $isbinary) {
641 my @srcinfo = binary_to_source(binary => $package,
642 version => $version);
644 # We know the source package(s). Use a fully-qualified version.
645 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
648 # Otherwise, an unqualified version will have to do.
652 # Strip off various kinds of brain-damage.
654 $version =~ s/ *\(.*\)//;
655 $version =~ s/ +[A-Za-z].*//;
657 foreach my $ver (split /[,\s]+/, $version) {
658 my $sver = defined($source) ? "$source/$ver" : '';
659 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
660 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
662 @{$data->{fixed_versions}} =
663 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
667 =head2 removefoundversions
669 removefoundversions($data,$package,$versiontoremove)
671 Removes found versions from $data
673 If a version is fully qualified (contains /) only versions matching
674 exactly are removed. Otherwise, all versions matching the version
677 Currently $package and $isbinary are entirely ignored, but accepted
678 for backwards compatibilty.
682 sub removefoundversions {
686 my $isbinary = shift;
687 return unless defined $version;
689 foreach my $ver (split /[,\s]+/, $version) {
691 # fully qualified version
692 @{$data->{found_versions}} =
694 @{$data->{found_versions}};
697 # non qualified version; delete all matchers
698 @{$data->{found_versions}} =
699 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
700 @{$data->{found_versions}};
706 sub addfixedversions {
710 my $isbinary = shift;
711 return unless defined $version;
712 undef $package if defined $package and $package =~ m[(?:\s|/)];
713 my $source = $package;
715 if (defined $package and $isbinary) {
716 my @srcinfo = binary_to_source(binary => $package,
717 version => $version);
719 # We know the source package(s). Use a fully-qualified version.
720 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
723 # Otherwise, an unqualified version will have to do.
727 # Strip off various kinds of brain-damage.
729 $version =~ s/ *\(.*\)//;
730 $version =~ s/ +[A-Za-z].*//;
732 foreach my $ver (split /[,\s]+/, $version) {
733 my $sver = defined($source) ? "$source/$ver" : '';
734 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
735 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
737 @{$data->{found_versions}} =
738 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
742 sub removefixedversions {
746 my $isbinary = shift;
747 return unless defined $version;
749 foreach my $ver (split /[,\s]+/, $version) {
751 # fully qualified version
752 @{$data->{fixed_versions}} =
754 @{$data->{fixed_versions}};
757 # non qualified version; delete all matchers
758 @{$data->{fixed_versions}} =
759 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
760 @{$data->{fixed_versions}};
771 Split a package string from the status file into a list of package names.
777 return unless defined $pkgs;
778 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
782 =head2 bug_archiveable
784 bug_archiveable(bug => $bug_num);
790 =item bug -- bug number (required)
792 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
794 =item version -- Debbugs::Version information (optional)
796 =item days_until -- return days until the bug can be archived
800 Returns 1 if the bug can be archived
801 Returns 0 if the bug cannot be archived
803 If days_until is true, returns the number of days until the bug can be
804 archived, -1 if it cannot be archived. 0 means that the bug can be
805 archived the next time the archiver runs.
807 Returns undef on failure.
811 # This will eventually need to be fixed before we start using mod_perl
812 our $version_cache = {};
814 my %param = validate_with(params => \@_,
815 spec => {bug => {type => SCALAR,
818 status => {type => HASHREF,
821 days_until => {type => BOOLEAN,
824 ignore_time => {type => BOOLEAN,
829 # This is what we return if the bug cannot be archived.
830 my $cannot_archive = $param{days_until}?-1:0;
831 # read the status information
832 my $status = $param{status};
833 if (not exists $param{status} or not defined $status) {
834 $status = read_bug(bug=>$param{bug});
835 if (not defined $status) {
836 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
840 # Bugs can be archived if they are
842 if (not defined $status->{done} or not length $status->{done}) {
843 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
844 return $cannot_archive
846 # Check to make sure that the bug has none of the unremovable tags set
847 if (@{$config{removal_unremovable_tags}}) {
848 for my $tag (split ' ', ($status->{tags}||'')) {
849 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
850 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
851 return $cannot_archive;
856 # If we just are checking if the bug can be archived, we'll not even bother
857 # checking the versioning information if the bug has been -done for less than 28 days.
858 my $log_file = getbugcomponent($param{bug},'log');
859 if (not defined $log_file) {
860 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
861 return $cannot_archive;
863 my $max_log_age = max(map {$config{remove_age} - -M $_}
864 $log_file, map {my $log = getbugcomponent($_,'log');
865 defined $log ? ($log) : ();
867 split / /, $status->{mergedwith}
869 if (not $param{days_until} and not $param{ignore_time}
872 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
873 return $cannot_archive;
875 # At this point, we have to get the versioning information for this bug.
876 # We examine the set of distribution tags. If a bug has no distribution
877 # tags set, we assume a default set, otherwise we use the tags the bug
880 # In cases where we are assuming a default set, if the severity
881 # is strong, we use the strong severity default; otherwise, we
882 # use the normal default.
884 # There must be fixed_versions for us to look at the versioning
886 my $min_fixed_time = time;
887 my $min_archive_days = 0;
888 if (@{$status->{fixed_versions}}) {
890 @dist_tags{@{$config{removal_distribution_tags}}} =
891 (1) x @{$config{removal_distribution_tags}};
893 for my $tag (split ' ', ($status->{tags}||'')) {
894 next unless exists $config{distribution_aliases}{$tag};
895 next unless $dist_tags{$config{distribution_aliases}{$tag}};
896 $dists{$config{distribution_aliases}{$tag}} = 1;
898 if (not keys %dists) {
899 if (isstrongseverity($status->{severity})) {
900 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
901 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
904 @dists{@{$config{removal_default_distribution_tags}}} =
905 (1) x @{$config{removal_default_distribution_tags}};
909 my @sourceversions = get_versions(package => $status->{package},
910 dist => [keys %dists],
913 @source_versions{@sourceversions} = (1) x @sourceversions;
914 # If the bug has not been fixed in the versions actually
915 # distributed, then it cannot be archived.
916 if ('found' eq max_buggy(bug => $param{bug},
917 sourceversions => [keys %source_versions],
918 found => $status->{found_versions},
919 fixed => $status->{fixed_versions},
920 version_cache => $version_cache,
921 package => $status->{package},
923 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
924 return $cannot_archive;
926 # Since the bug has at least been fixed in the architectures
927 # that matters, we check to see how long it has been fixed.
929 # If $param{ignore_time}, then we should ignore time.
930 if ($param{ignore_time}) {
931 return $param{days_until}?0:1;
934 # To do this, we order the times from most recent to oldest;
935 # when we come to the first found version, we stop.
936 # If we run out of versions, we only report the time of the
938 my %time_versions = get_versions(package => $status->{package},
939 dist => [keys %dists],
943 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
944 my $buggy = buggy(bug => $param{bug},
946 found => $status->{found_versions},
947 fixed => $status->{fixed_versions},
948 version_cache => $version_cache,
949 package => $status->{package},
951 last if $buggy eq 'found';
952 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
954 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
955 # if there are no versions in the archive at all, then
956 # we can archive if enough days have passed
959 # If $param{ignore_time}, then we should ignore time.
960 if ($param{ignore_time}) {
961 return $param{days_until}?0:1;
963 # 6. at least 28 days have passed since the last action has occured or the bug was closed
964 my $age = ceil($max_log_age);
965 if ($age > 0 or $min_archive_days > 0) {
966 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
967 return $param{days_until}?max($age,$min_archive_days):0;
970 return $param{days_until}?0:1;
975 =head2 get_bug_status
977 my $status = get_bug_status(bug => $nnn);
979 my $status = get_bug_status($bug_num)
985 =item bug -- scalar bug number
987 =item status -- optional hashref of bug status as returned by readbug
988 (can be passed to avoid rereading the bug information)
990 =item bug_index -- optional tied index of bug status infomration;
991 currently not correctly implemented.
993 =item version -- optional version(s) to check package status at
995 =item dist -- optional distribution(s) to check package status at
997 =item arch -- optional architecture(s) to check package status at
999 =item bugusertags -- optional hashref of bugusertags
1001 =item sourceversion -- optional arrayref of source/version; overrides
1002 dist, arch, and version. [The entries in this array must be in the
1003 "source/version" format.] Eventually this can be used to for caching.
1005 =item indicatesource -- if true, indicate which source packages this
1006 bug could belong to (or does belong to in the case of bugs assigned to
1007 a source package). Defaults to true.
1011 Note: Currently the version information is cached; this needs to be
1012 changed before using this function in long lived programs.
1016 sub get_bug_status {
1020 my %param = validate_with(params => \@_,
1021 spec => {bug => {type => SCALAR,
1024 status => {type => HASHREF,
1027 bug_index => {type => OBJECT,
1030 version => {type => SCALAR|ARRAYREF,
1033 dist => {type => SCALAR|ARRAYREF,
1036 arch => {type => SCALAR|ARRAYREF,
1039 bugusertags => {type => HASHREF,
1042 sourceversions => {type => ARRAYREF,
1045 indicatesource => {type => BOOLEAN,
1052 if (defined $param{bug_index} and
1053 exists $param{bug_index}{$param{bug}}) {
1054 %status = %{ $param{bug_index}{$param{bug}} };
1055 $status{pending} = $status{ status };
1056 $status{id} = $param{bug};
1059 if (defined $param{status}) {
1060 %status = %{$param{status}};
1063 my $location = getbuglocation($param{bug}, 'summary');
1064 return {} if not defined $location or not length $location;
1065 %status = %{ readbug( $param{bug}, $location ) };
1067 $status{id} = $param{bug};
1069 if (defined $param{bugusertags}{$param{bug}}) {
1070 $status{keywords} = "" unless defined $status{keywords};
1071 $status{keywords} .= " " unless $status{keywords} eq "";
1072 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1074 $status{tags} = $status{keywords};
1075 my %tags = map { $_ => 1 } split ' ', $status{tags};
1077 $status{package} = '' if not defined $status{package};
1078 $status{"package"} =~ s/\s*$//;
1080 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1084 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1085 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1087 $status{"pending"} = 'pending';
1088 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1089 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1090 $status{"pending"} = 'fixed' if ($tags{fixed});
1093 my $presence = bug_presence(status => \%status,
1094 map{(exists $param{$_})?($_,$param{$_}):()}
1095 qw(bug sourceversions arch dist version found fixed package)
1097 if (defined $presence) {
1098 if ($presence eq 'fixed') {
1099 $status{pending} = 'done';
1101 elsif ($presence eq 'absent') {
1102 $status{pending} = 'absent';
1110 my $precence = bug_presence(bug => nnn,
1114 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1115 is found, absent, fixed, or no information is available in the
1116 distribution (dist) and/or architecture (arch) specified.
1123 =item bug -- scalar bug number
1125 =item status -- optional hashref of bug status as returned by readbug
1126 (can be passed to avoid rereading the bug information)
1128 =item bug_index -- optional tied index of bug status infomration;
1129 currently not correctly implemented.
1131 =item version -- optional version to check package status at
1133 =item dist -- optional distribution to check package status at
1135 =item arch -- optional architecture to check package status at
1137 =item sourceversion -- optional arrayref of source/version; overrides
1138 dist, arch, and version. [The entries in this array must be in the
1139 "source/version" format.] Eventually this can be used to for caching.
1146 my %param = validate_with(params => \@_,
1147 spec => {bug => {type => SCALAR,
1150 status => {type => HASHREF,
1153 version => {type => SCALAR|ARRAYREF,
1156 dist => {type => SCALAR|ARRAYREF,
1159 arch => {type => SCALAR|ARRAYREF,
1162 sourceversions => {type => ARRAYREF,
1168 if (defined $param{status}) {
1169 %status = %{$param{status}};
1172 my $location = getbuglocation($param{bug}, 'summary');
1173 return {} if not length $location;
1174 %status = %{ readbug( $param{bug}, $location ) };
1178 my $pseudo_desc = getpseudodesc();
1179 if (not exists $param{sourceversions}) {
1181 # pseudopackages do not have source versions by definition.
1182 if (exists $pseudo_desc->{$status{package}}) {
1185 elsif (defined $param{version}) {
1186 foreach my $arch (make_list($param{arch})) {
1187 for my $package (split /\s*,\s*/, $status{package}) {
1188 my @temp = makesourceversions($package,
1190 make_list($param{version})
1192 @sourceversions{@temp} = (1) x @temp;
1195 } elsif (defined $param{dist}) {
1196 my %affects_distribution_tags;
1197 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1198 (1) x @{$config{affects_distribution_tags}};
1199 my $some_distributions_disallowed = 0;
1200 my %allowed_distributions;
1201 for my $tag (split ' ', ($status{tags}||'')) {
1202 if (exists $config{distribution_aliases}{$tag} and
1203 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1204 $some_distributions_disallowed = 1;
1205 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1207 elsif (exists $affects_distribution_tags{$tag}) {
1208 $some_distributions_disallowed = 1;
1209 $allowed_distributions{$tag} = 1;
1212 my @archs = make_list(exists $param{arch}?$param{arch}:());
1213 GET_SOURCE_VERSIONS:
1214 foreach my $arch (@archs) {
1215 for my $package (split /\s*,\s*/, $status{package}) {
1218 if ($package =~ /^src:(.+)$/) {
1222 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1223 # if some distributions are disallowed,
1224 # and this isn't an allowed
1225 # distribution, then we ignore this
1226 # distribution for the purposees of
1228 if ($some_distributions_disallowed and
1229 not exists $allowed_distributions{$dist}) {
1232 push @versions, get_versions(package => $package,
1234 ($source?(arch => 'source'):
1235 (defined $arch?(arch => $arch):())),
1238 next unless @versions;
1239 my @temp = make_source_versions(package => $package,
1241 versions => \@versions,
1243 @sourceversions{@temp} = (1) x @temp;
1246 # this should really be split out into a subroutine,
1247 # but it'd touch so many things currently, that we fake
1248 # it; it's needed to properly handle bugs which are
1249 # erroneously assigned to the binary package, and we'll
1250 # probably have it go away eventually.
1251 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1253 goto GET_SOURCE_VERSIONS;
1257 # TODO: This should probably be handled further out for efficiency and
1258 # for more ease of distinguishing between pkg= and src= queries.
1259 # DLA: src= queries should just pass arch=source, and they'll be happy.
1260 @sourceversions = keys %sourceversions;
1263 @sourceversions = @{$param{sourceversions}};
1265 my $maxbuggy = 'undef';
1266 if (@sourceversions) {
1267 $maxbuggy = max_buggy(bug => $param{bug},
1268 sourceversions => \@sourceversions,
1269 found => $status{found_versions},
1270 fixed => $status{fixed_versions},
1271 package => $status{package},
1272 version_cache => $version_cache,
1275 elsif (defined $param{dist} and
1276 not exists $pseudo_desc->{$status{package}}) {
1279 if (length($status{done}) and
1280 (not @sourceversions or not @{$status{fixed_versions}})) {
1295 =item bug -- scalar bug number
1297 =item sourceversion -- optional arrayref of source/version; overrides
1298 dist, arch, and version. [The entries in this array must be in the
1299 "source/version" format.] Eventually this can be used to for caching.
1303 Note: Currently the version information is cached; this needs to be
1304 changed before using this function in long lived programs.
1309 my %param = validate_with(params => \@_,
1310 spec => {bug => {type => SCALAR,
1313 sourceversions => {type => ARRAYREF,
1316 found => {type => ARRAYREF,
1319 fixed => {type => ARRAYREF,
1322 package => {type => SCALAR,
1324 version_cache => {type => HASHREF,
1329 # Resolve bugginess states (we might be looking at multiple
1330 # architectures, say). Found wins, then fixed, then absent.
1331 my $maxbuggy = 'absent';
1332 for my $package (split /\s*,\s*/, $param{package}) {
1333 for my $version (@{$param{sourceversions}}) {
1334 my $buggy = buggy(bug => $param{bug},
1335 version => $version,
1336 found => $param{found},
1337 fixed => $param{fixed},
1338 version_cache => $param{version_cache},
1339 package => $package,
1341 if ($buggy eq 'found') {
1343 } elsif ($buggy eq 'fixed') {
1344 $maxbuggy = 'fixed';
1361 Returns the output of Debbugs::Versions::buggy for a particular
1362 package, version and found/fixed set. Automatically turns found, fixed
1363 and version into source/version strings.
1365 Caching can be had by using the version_cache, but no attempt to check
1366 to see if the on disk information is more recent than the cache is
1367 made. [This will need to be fixed for long-lived processes.]
1372 my %param = validate_with(params => \@_,
1373 spec => {bug => {type => SCALAR,
1376 found => {type => ARRAYREF,
1379 fixed => {type => ARRAYREF,
1382 version_cache => {type => HASHREF,
1385 package => {type => SCALAR,
1387 version => {type => SCALAR,
1391 my @found = @{$param{found}};
1392 my @fixed = @{$param{fixed}};
1393 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1394 # We have non-source version versions
1395 @found = makesourceversions($param{package},undef,
1398 @fixed = makesourceversions($param{package},undef,
1402 if ($param{version} !~ m{/}) {
1403 my ($version) = makesourceversions($param{package},undef,
1406 $param{version} = $version if defined $version;
1408 # Figure out which source packages we need
1410 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1411 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1412 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1413 $param{version} =~ m{/};
1415 if (not defined $param{version_cache} or
1416 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1417 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1418 foreach my $source (keys %sources) {
1419 my $srchash = substr $source, 0, 1;
1420 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1421 if (not defined $version_fh) {
1422 # We only want to warn if it's a package which actually has a maintainer
1423 my $maints = getmaintainers();
1424 next if not exists $maints->{$source};
1425 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1428 $version->load($version_fh);
1430 if (defined $param{version_cache}) {
1431 $param{version_cache}{join(',',sort keys %sources)} = $version;
1435 $version = $param{version_cache}{join(',',sort keys %sources)};
1437 return $version->buggy($param{version},\@found,\@fixed);
1440 sub isstrongseverity {
1441 my $severity = shift;
1442 $severity = $config{default_severity} if
1443 not defined $severity or $severity eq '';
1444 return grep { $_ eq $severity } @{$config{strong_severities}};
1448 =head1 PRIVATE FUNCTIONS
1452 sub update_realtime {
1453 my ($file, %bugs) = @_;
1455 # update realtime index.db
1457 return () unless keys %bugs;
1458 my $idx_old = IO::File->new($file,'r')
1459 or die "Couldn't open ${file}: $!";
1460 my $idx_new = IO::File->new($file.'.new','w')
1461 or die "Couldn't open ${file}.new: $!";
1463 my $min_bug = min(keys %bugs);
1467 while($line = <$idx_old>) {
1468 @line = split /\s/, $line;
1469 # Two cases; replacing existing line or adding new line
1470 if (exists $bugs{$line[1]}) {
1471 my $new = $bugs{$line[1]};
1472 delete $bugs{$line[1]};
1473 $min_bug = min(keys %bugs);
1474 if ($new eq "NOCHANGE") {
1475 print {$idx_new} $line;
1476 $changed_bugs{$line[1]} = $line;
1477 } elsif ($new eq "REMOVE") {
1478 $changed_bugs{$line[1]} = $line;
1480 print {$idx_new} $new;
1481 $changed_bugs{$line[1]} = $line;
1485 while ($line[1] > $min_bug) {
1486 print {$idx_new} $bugs{$min_bug};
1487 delete $bugs{$min_bug};
1488 last unless keys %bugs;
1489 $min_bug = min(keys %bugs);
1491 print {$idx_new} $line;
1493 last unless keys %bugs;
1495 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1497 print {$idx_new} <$idx_old>;
1502 rename("$file.new", $file);
1504 return %changed_bugs;
1507 sub bughook_archive {
1509 &filelock("$config{spool_dir}/debbugs.trace.lock");
1510 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1511 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1512 map{($_,'REMOVE')} @refs);
1513 update_realtime("$config{spool_dir}/index.archive.realtime",
1519 my ( $type, %bugs_temp ) = @_;
1520 &filelock("$config{spool_dir}/debbugs.trace.lock");
1523 for my $bug (keys %bugs_temp) {
1524 my $data = $bugs_temp{$bug};
1525 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1527 my $whendone = "open";
1528 my $severity = $config{default_severity};
1529 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1530 $pkglist =~ s/^,+//;
1531 $pkglist =~ s/,+$//;
1532 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1533 $whendone = "done" if defined $data->{done} and length $data->{done};
1534 $severity = $data->{severity} if length $data->{severity};
1536 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1537 $pkglist, $bug, $data->{date}, $whendone,
1538 $data->{originator}, $severity, $data->{keywords};
1541 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);