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);
627 sub addfoundversions {
631 my $isbinary = shift;
632 return unless defined $version;
633 undef $package if $package =~ m[(?:\s|/)];
634 my $source = $package;
636 if (defined $package and $isbinary) {
637 my @srcinfo = binary_to_source(binary => $package,
638 version => $version);
640 # We know the source package(s). Use a fully-qualified version.
641 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
644 # Otherwise, an unqualified version will have to do.
648 # Strip off various kinds of brain-damage.
650 $version =~ s/ *\(.*\)//;
651 $version =~ s/ +[A-Za-z].*//;
653 foreach my $ver (split /[,\s]+/, $version) {
654 my $sver = defined($source) ? "$source/$ver" : '';
655 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
656 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
658 @{$data->{fixed_versions}} =
659 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
663 =head2 removefoundversions
665 removefoundversions($data,$package,$versiontoremove)
667 Removes found versions from $data
669 If a version is fully qualified (contains /) only versions matching
670 exactly are removed. Otherwise, all versions matching the version
673 Currently $package and $isbinary are entirely ignored, but accepted
674 for backwards compatibilty.
678 sub removefoundversions {
682 my $isbinary = shift;
683 return unless defined $version;
685 foreach my $ver (split /[,\s]+/, $version) {
687 # fully qualified version
688 @{$data->{found_versions}} =
690 @{$data->{found_versions}};
693 # non qualified version; delete all matchers
694 @{$data->{found_versions}} =
695 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
696 @{$data->{found_versions}};
702 sub addfixedversions {
706 my $isbinary = shift;
707 return unless defined $version;
708 undef $package if defined $package and $package =~ m[(?:\s|/)];
709 my $source = $package;
711 if (defined $package and $isbinary) {
712 my @srcinfo = binary_to_source(binary => $package,
713 version => $version);
715 # We know the source package(s). Use a fully-qualified version.
716 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
719 # Otherwise, an unqualified version will have to do.
723 # Strip off various kinds of brain-damage.
725 $version =~ s/ *\(.*\)//;
726 $version =~ s/ +[A-Za-z].*//;
728 foreach my $ver (split /[,\s]+/, $version) {
729 my $sver = defined($source) ? "$source/$ver" : '';
730 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
731 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
733 @{$data->{found_versions}} =
734 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
738 sub removefixedversions {
742 my $isbinary = shift;
743 return unless defined $version;
745 foreach my $ver (split /[,\s]+/, $version) {
747 # fully qualified version
748 @{$data->{fixed_versions}} =
750 @{$data->{fixed_versions}};
753 # non qualified version; delete all matchers
754 @{$data->{fixed_versions}} =
755 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
756 @{$data->{fixed_versions}};
767 Split a package string from the status file into a list of package names.
773 return unless defined $pkgs;
774 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
778 =head2 bug_archiveable
780 bug_archiveable(bug => $bug_num);
786 =item bug -- bug number (required)
788 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
790 =item version -- Debbugs::Version information (optional)
792 =item days_until -- return days until the bug can be archived
796 Returns 1 if the bug can be archived
797 Returns 0 if the bug cannot be archived
799 If days_until is true, returns the number of days until the bug can be
800 archived, -1 if it cannot be archived. 0 means that the bug can be
801 archived the next time the archiver runs.
803 Returns undef on failure.
807 # This will eventually need to be fixed before we start using mod_perl
808 our $version_cache = {};
810 my %param = validate_with(params => \@_,
811 spec => {bug => {type => SCALAR,
814 status => {type => HASHREF,
817 days_until => {type => BOOLEAN,
820 ignore_time => {type => BOOLEAN,
825 # This is what we return if the bug cannot be archived.
826 my $cannot_archive = $param{days_until}?-1:0;
827 # read the status information
828 my $status = $param{status};
829 if (not exists $param{status} or not defined $status) {
830 $status = read_bug(bug=>$param{bug});
831 if (not defined $status) {
832 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
836 # Bugs can be archived if they are
838 if (not defined $status->{done} or not length $status->{done}) {
839 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
840 return $cannot_archive
842 # Check to make sure that the bug has none of the unremovable tags set
843 if (@{$config{removal_unremovable_tags}}) {
844 for my $tag (split ' ', ($status->{tags}||'')) {
845 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
846 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
847 return $cannot_archive;
852 # If we just are checking if the bug can be archived, we'll not even bother
853 # checking the versioning information if the bug has been -done for less than 28 days.
854 my $log_file = getbugcomponent($param{bug},'log');
855 if (not defined $log_file) {
856 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
857 return $cannot_archive;
859 my $max_log_age = max(map {$config{remove_age} - -M $_}
860 $log_file, map {my $log = getbugcomponent($_,'log');
861 defined $log ? ($log) : ();
863 split / /, $status->{mergedwith}
865 if (not $param{days_until} and not $param{ignore_time}
868 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
869 return $cannot_archive;
871 # At this point, we have to get the versioning information for this bug.
872 # We examine the set of distribution tags. If a bug has no distribution
873 # tags set, we assume a default set, otherwise we use the tags the bug
876 # In cases where we are assuming a default set, if the severity
877 # is strong, we use the strong severity default; otherwise, we
878 # use the normal default.
880 # There must be fixed_versions for us to look at the versioning
882 my $min_fixed_time = time;
883 my $min_archive_days = 0;
884 if (@{$status->{fixed_versions}}) {
886 @dist_tags{@{$config{removal_distribution_tags}}} =
887 (1) x @{$config{removal_distribution_tags}};
889 for my $tag (split ' ', ($status->{tags}||'')) {
890 next unless exists $config{distribution_aliases}{$tag};
891 next unless $dist_tags{$config{distribution_aliases}{$tag}};
892 $dists{$config{distribution_aliases}{$tag}} = 1;
894 if (not keys %dists) {
895 if (isstrongseverity($status->{severity})) {
896 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
897 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
900 @dists{@{$config{removal_default_distribution_tags}}} =
901 (1) x @{$config{removal_default_distribution_tags}};
905 my @sourceversions = get_versions(package => $status->{package},
906 dist => [keys %dists],
909 @source_versions{@sourceversions} = (1) x @sourceversions;
910 # If the bug has not been fixed in the versions actually
911 # distributed, then it cannot be archived.
912 if ('found' eq max_buggy(bug => $param{bug},
913 sourceversions => [keys %source_versions],
914 found => $status->{found_versions},
915 fixed => $status->{fixed_versions},
916 version_cache => $version_cache,
917 package => $status->{package},
919 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
920 return $cannot_archive;
922 # Since the bug has at least been fixed in the architectures
923 # that matters, we check to see how long it has been fixed.
925 # If $param{ignore_time}, then we should ignore time.
926 if ($param{ignore_time}) {
927 return $param{days_until}?0:1;
930 # To do this, we order the times from most recent to oldest;
931 # when we come to the first found version, we stop.
932 # If we run out of versions, we only report the time of the
934 my %time_versions = get_versions(package => $status->{package},
935 dist => [keys %dists],
939 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
940 my $buggy = buggy(bug => $param{bug},
942 found => $status->{found_versions},
943 fixed => $status->{fixed_versions},
944 version_cache => $version_cache,
945 package => $status->{package},
947 last if $buggy eq 'found';
948 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
950 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
951 # if there are no versions in the archive at all, then
952 # we can archive if enough days have passed
955 # If $param{ignore_time}, then we should ignore time.
956 if ($param{ignore_time}) {
957 return $param{days_until}?0:1;
959 # 6. at least 28 days have passed since the last action has occured or the bug was closed
960 my $age = ceil($max_log_age);
961 if ($age > 0 or $min_archive_days > 0) {
962 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
963 return $param{days_until}?max($age,$min_archive_days):0;
966 return $param{days_until}?0:1;
971 =head2 get_bug_status
973 my $status = get_bug_status(bug => $nnn);
975 my $status = get_bug_status($bug_num)
981 =item bug -- scalar bug number
983 =item status -- optional hashref of bug status as returned by readbug
984 (can be passed to avoid rereading the bug information)
986 =item bug_index -- optional tied index of bug status infomration;
987 currently not correctly implemented.
989 =item version -- optional version(s) to check package status at
991 =item dist -- optional distribution(s) to check package status at
993 =item arch -- optional architecture(s) to check package status at
995 =item bugusertags -- optional hashref of bugusertags
997 =item sourceversion -- optional arrayref of source/version; overrides
998 dist, arch, and version. [The entries in this array must be in the
999 "source/version" format.] Eventually this can be used to for caching.
1001 =item indicatesource -- if true, indicate which source packages this
1002 bug could belong to (or does belong to in the case of bugs assigned to
1003 a source package). Defaults to true.
1007 Note: Currently the version information is cached; this needs to be
1008 changed before using this function in long lived programs.
1012 sub get_bug_status {
1016 my %param = validate_with(params => \@_,
1017 spec => {bug => {type => SCALAR,
1020 status => {type => HASHREF,
1023 bug_index => {type => OBJECT,
1026 version => {type => SCALAR|ARRAYREF,
1029 dist => {type => SCALAR|ARRAYREF,
1032 arch => {type => SCALAR|ARRAYREF,
1035 bugusertags => {type => HASHREF,
1038 sourceversions => {type => ARRAYREF,
1041 indicatesource => {type => BOOLEAN,
1048 if (defined $param{bug_index} and
1049 exists $param{bug_index}{$param{bug}}) {
1050 %status = %{ $param{bug_index}{$param{bug}} };
1051 $status{pending} = $status{ status };
1052 $status{id} = $param{bug};
1055 if (defined $param{status}) {
1056 %status = %{$param{status}};
1059 my $location = getbuglocation($param{bug}, 'summary');
1060 return {} if not defined $location or not length $location;
1061 %status = %{ readbug( $param{bug}, $location ) };
1063 $status{id} = $param{bug};
1065 if (defined $param{bugusertags}{$param{bug}}) {
1066 $status{keywords} = "" unless defined $status{keywords};
1067 $status{keywords} .= " " unless $status{keywords} eq "";
1068 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1070 $status{tags} = $status{keywords};
1071 my %tags = map { $_ => 1 } split ' ', $status{tags};
1073 $status{package} = '' if not defined $status{package};
1074 $status{"package"} =~ s/\s*$//;
1076 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1080 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1081 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1083 $status{"pending"} = 'pending';
1084 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1085 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1086 $status{"pending"} = 'fixed' if ($tags{fixed});
1089 my $presence = bug_presence(status => \%status,
1090 map{(exists $param{$_})?($_,$param{$_}):()}
1091 qw(bug sourceversions arch dist version found fixed package)
1093 if (defined $presence) {
1094 if ($presence eq 'fixed') {
1095 $status{pending} = 'done';
1097 elsif ($presence eq 'absent') {
1098 $status{pending} = 'absent';
1106 my $precence = bug_presence(bug => nnn,
1110 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1111 is found, absent, fixed, or no information is available in the
1112 distribution (dist) and/or architecture (arch) specified.
1119 =item bug -- scalar bug number
1121 =item status -- optional hashref of bug status as returned by readbug
1122 (can be passed to avoid rereading the bug information)
1124 =item bug_index -- optional tied index of bug status infomration;
1125 currently not correctly implemented.
1127 =item version -- optional version to check package status at
1129 =item dist -- optional distribution to check package status at
1131 =item arch -- optional architecture to check package status at
1133 =item sourceversion -- optional arrayref of source/version; overrides
1134 dist, arch, and version. [The entries in this array must be in the
1135 "source/version" format.] Eventually this can be used to for caching.
1142 my %param = validate_with(params => \@_,
1143 spec => {bug => {type => SCALAR,
1146 status => {type => HASHREF,
1149 version => {type => SCALAR|ARRAYREF,
1152 dist => {type => SCALAR|ARRAYREF,
1155 arch => {type => SCALAR|ARRAYREF,
1158 sourceversions => {type => ARRAYREF,
1164 if (defined $param{status}) {
1165 %status = %{$param{status}};
1168 my $location = getbuglocation($param{bug}, 'summary');
1169 return {} if not length $location;
1170 %status = %{ readbug( $param{bug}, $location ) };
1174 my $pseudo_desc = getpseudodesc();
1175 if (not exists $param{sourceversions}) {
1177 # pseudopackages do not have source versions by definition.
1178 if (exists $pseudo_desc->{$status{package}}) {
1181 elsif (defined $param{version}) {
1182 foreach my $arch (make_list($param{arch})) {
1183 for my $package (split /\s*,\s*/, $status{package}) {
1184 my @temp = makesourceversions($package,
1186 make_list($param{version})
1188 @sourceversions{@temp} = (1) x @temp;
1191 } elsif (defined $param{dist}) {
1192 my %affects_distribution_tags;
1193 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1194 (1) x @{$config{affects_distribution_tags}};
1195 my $some_distributions_disallowed = 0;
1196 my %allowed_distributions;
1197 for my $tag (split ' ', ($status{tags}||'')) {
1198 if (exists $config{distribution_aliases}{$tag} and
1199 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1200 $some_distributions_disallowed = 1;
1201 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1203 elsif (exists $affects_distribution_tags{$tag}) {
1204 $some_distributions_disallowed = 1;
1205 $allowed_distributions{$tag} = 1;
1208 my @archs = make_list(exists $param{arch}?$param{arch}:());
1209 GET_SOURCE_VERSIONS:
1210 foreach my $arch (@archs) {
1211 for my $package (split /\s*,\s*/, $status{package}) {
1214 if ($package =~ /^src:(.+)$/) {
1218 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1219 # if some distributions are disallowed,
1220 # and this isn't an allowed
1221 # distribution, then we ignore this
1222 # distribution for the purposees of
1224 if ($some_distributions_disallowed and
1225 not exists $allowed_distributions{$dist}) {
1228 push @versions, get_versions(package => $package,
1230 ($source?(arch => 'source'):
1231 (defined $arch?(arch => $arch):())),
1234 next unless @versions;
1235 my @temp = make_source_versions(package => $package,
1237 versions => \@versions,
1239 @sourceversions{@temp} = (1) x @temp;
1242 # this should really be split out into a subroutine,
1243 # but it'd touch so many things currently, that we fake
1244 # it; it's needed to properly handle bugs which are
1245 # erroneously assigned to the binary package, and we'll
1246 # probably have it go away eventually.
1247 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1249 goto GET_SOURCE_VERSIONS;
1253 # TODO: This should probably be handled further out for efficiency and
1254 # for more ease of distinguishing between pkg= and src= queries.
1255 # DLA: src= queries should just pass arch=source, and they'll be happy.
1256 @sourceversions = keys %sourceversions;
1259 @sourceversions = @{$param{sourceversions}};
1261 my $maxbuggy = 'undef';
1262 if (@sourceversions) {
1263 $maxbuggy = max_buggy(bug => $param{bug},
1264 sourceversions => \@sourceversions,
1265 found => $status{found_versions},
1266 fixed => $status{fixed_versions},
1267 package => $status{package},
1268 version_cache => $version_cache,
1271 elsif (defined $param{dist} and
1272 not exists $pseudo_desc->{$status{package}}) {
1275 if (length($status{done}) and
1276 (not @sourceversions or not @{$status{fixed_versions}})) {
1291 =item bug -- scalar bug number
1293 =item sourceversion -- optional arrayref of source/version; overrides
1294 dist, arch, and version. [The entries in this array must be in the
1295 "source/version" format.] Eventually this can be used to for caching.
1299 Note: Currently the version information is cached; this needs to be
1300 changed before using this function in long lived programs.
1305 my %param = validate_with(params => \@_,
1306 spec => {bug => {type => SCALAR,
1309 sourceversions => {type => ARRAYREF,
1312 found => {type => ARRAYREF,
1315 fixed => {type => ARRAYREF,
1318 package => {type => SCALAR,
1320 version_cache => {type => HASHREF,
1325 # Resolve bugginess states (we might be looking at multiple
1326 # architectures, say). Found wins, then fixed, then absent.
1327 my $maxbuggy = 'absent';
1328 for my $package (split /\s*,\s*/, $param{package}) {
1329 for my $version (@{$param{sourceversions}}) {
1330 my $buggy = buggy(bug => $param{bug},
1331 version => $version,
1332 found => $param{found},
1333 fixed => $param{fixed},
1334 version_cache => $param{version_cache},
1335 package => $package,
1337 if ($buggy eq 'found') {
1339 } elsif ($buggy eq 'fixed') {
1340 $maxbuggy = 'fixed';
1357 Returns the output of Debbugs::Versions::buggy for a particular
1358 package, version and found/fixed set. Automatically turns found, fixed
1359 and version into source/version strings.
1361 Caching can be had by using the version_cache, but no attempt to check
1362 to see if the on disk information is more recent than the cache is
1363 made. [This will need to be fixed for long-lived processes.]
1368 my %param = validate_with(params => \@_,
1369 spec => {bug => {type => SCALAR,
1372 found => {type => ARRAYREF,
1375 fixed => {type => ARRAYREF,
1378 version_cache => {type => HASHREF,
1381 package => {type => SCALAR,
1383 version => {type => SCALAR,
1387 my @found = @{$param{found}};
1388 my @fixed = @{$param{fixed}};
1389 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1390 # We have non-source version versions
1391 @found = makesourceversions($param{package},undef,
1394 @fixed = makesourceversions($param{package},undef,
1398 if ($param{version} !~ m{/}) {
1399 my ($version) = makesourceversions($param{package},undef,
1402 $param{version} = $version if defined $version;
1404 # Figure out which source packages we need
1406 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1407 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1408 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1409 $param{version} =~ m{/};
1411 if (not defined $param{version_cache} or
1412 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1413 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1414 foreach my $source (keys %sources) {
1415 my $srchash = substr $source, 0, 1;
1416 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1417 if (not defined $version_fh) {
1418 # We only want to warn if it's a package which actually has a maintainer
1419 my $maints = getmaintainers();
1420 next if not exists $maints->{$source};
1421 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1424 $version->load($version_fh);
1426 if (defined $param{version_cache}) {
1427 $param{version_cache}{join(',',sort keys %sources)} = $version;
1431 $version = $param{version_cache}{join(',',sort keys %sources)};
1433 return $version->buggy($param{version},\@found,\@fixed);
1436 sub isstrongseverity {
1437 my $severity = shift;
1438 $severity = $config{default_severity} if
1439 not defined $severity or $severity eq '';
1440 return grep { $_ eq $severity } @{$config{strong_severities}};
1444 =head1 PRIVATE FUNCTIONS
1448 sub update_realtime {
1449 my ($file, %bugs) = @_;
1451 # update realtime index.db
1453 return () unless keys %bugs;
1454 my $idx_old = IO::File->new($file,'r')
1455 or die "Couldn't open ${file}: $!";
1456 my $idx_new = IO::File->new($file.'.new','w')
1457 or die "Couldn't open ${file}.new: $!";
1459 my $min_bug = min(keys %bugs);
1463 while($line = <$idx_old>) {
1464 @line = split /\s/, $line;
1465 # Two cases; replacing existing line or adding new line
1466 if (exists $bugs{$line[1]}) {
1467 my $new = $bugs{$line[1]};
1468 delete $bugs{$line[1]};
1469 $min_bug = min(keys %bugs);
1470 if ($new eq "NOCHANGE") {
1471 print {$idx_new} $line;
1472 $changed_bugs{$line[1]} = $line;
1473 } elsif ($new eq "REMOVE") {
1474 $changed_bugs{$line[1]} = $line;
1476 print {$idx_new} $new;
1477 $changed_bugs{$line[1]} = $line;
1481 while ($line[1] > $min_bug) {
1482 print {$idx_new} $bugs{$min_bug};
1483 delete $bugs{$min_bug};
1484 last unless keys %bugs;
1485 $min_bug = min(keys %bugs);
1487 print {$idx_new} $line;
1489 last unless keys %bugs;
1491 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1493 print {$idx_new} <$idx_old>;
1498 rename("$file.new", $file);
1500 return %changed_bugs;
1503 sub bughook_archive {
1505 &filelock("$config{spool_dir}/debbugs.trace.lock");
1506 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1507 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1508 map{($_,'REMOVE')} @refs);
1509 update_realtime("$config{spool_dir}/index.archive.realtime",
1515 my ( $type, %bugs_temp ) = @_;
1516 &filelock("$config{spool_dir}/debbugs.trace.lock");
1519 for my $bug (keys %bugs_temp) {
1520 my $data = $bugs_temp{$bug};
1521 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1523 my $whendone = "open";
1524 my $severity = $config{default_severity};
1525 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1526 $pkglist =~ s/^,+//;
1527 $pkglist =~ s/,+$//;
1528 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1529 $whendone = "done" if defined $data->{done} and length $data->{done};
1530 $severity = $data->{severity} if length $data->{severity};
1532 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1533 $pkglist, $bug, $data->{date}, $whendone,
1534 $data->{originator}, $severity, $data->{keywords};
1537 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);