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 binarytosource);
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 $data{$namemap{$name}} = $value if exists $namemap{$name};
238 for my $field (keys %fields) {
239 $data{$field} = '' unless exists $data{$field};
242 $data{severity} = $config{default_severity} if $data{severity} eq '';
243 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
244 $data{$field} = [split ' ', $data{$field}];
246 for my $field (qw(found fixed)) {
247 # create the found/fixed hashes which indicate when a
248 # particular version was marked found or marked fixed.
249 @{$data{$field}}{@{$data{"${field}_versions"}}} =
250 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
251 @{$data{"${field}_date"}});
255 for my $field (@rfc1522_fields) {
256 $data{$field} = decode_rfc1522($data{$field});
259 my $status_modified = (stat($status))[9];
260 # Add log last modified time
261 $data{log_modified} = (stat($log))[9];
262 $data{last_modified} = max($status_modified,$data{log_modified});
263 $data{location} = $location;
264 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
265 $data{bug_num} = $param{bug};
270 =head2 split_status_fields
272 my @data = split_status_fields(@data);
274 Splits splittable status fields (like package, tags, blocks,
275 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
276 passed @data intact using dclone.
278 In scalar context, returns only the first element of @data.
282 our $ditch_empty = sub{
284 my $splitter = shift @t;
285 return grep {length $_} map {split $splitter} @t;
288 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
290 (package => \&splitpackages,
291 affects => \&splitpackages,
292 blocks => $ditch_empty_space,
293 blockedby => $ditch_empty_space,
294 tags => $ditch_empty_space,
295 found_versions => $ditch_empty_space,
296 fixed_versions => $ditch_empty_space,
297 mergedwith => $ditch_empty_space,
300 sub split_status_fields {
301 my @data = @{dclone(\@_)};
302 for my $data (@data) {
303 next if not defined $data;
304 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
305 not (ref($data) and ref($data) eq 'HASH');
306 for my $field (keys %{$data}) {
307 next unless defined $data->{$field};
308 if (exists $split_fields{$field}) {
309 next if ref($data->{$field});
311 if (ref($split_fields{$field}) eq 'CODE') {
312 @elements = &{$split_fields{$field}}($data->{$field});
314 elsif (not ref($split_fields{$field}) or
315 UNIVERSAL::isa($split_fields{$field},'Regex')
317 @elements = split $split_fields{$field}, $data->{$field};
319 $data->{$field} = \@elements;
323 return wantarray?@data:$data[0];
326 =head2 join_status_fields
328 my @data = join_status_fields(@data);
330 Handles joining the splitable status fields. (Basically, the inverse
331 of split_status_fields.
333 Primarily called from makestatus, but may be useful for other
334 functions after calling split_status_fields (or for legacy functions
335 if we transition to split fields by default).
339 sub join_status_fields {
346 found_versions => ' ',
347 fixed_versions => ' ',
352 my @data = @{dclone(\@_)};
353 for my $data (@data) {
354 next if not defined $data;
355 croak "Passed an element which is not a hashref to split_status_field: ".
357 if ref($data) ne 'HASH';
358 for my $field (keys %{$data}) {
359 next unless defined $data->{$field};
360 next unless ref($data->{$field}) eq 'ARRAY';
361 next unless exists $join_fields{$field};
362 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
365 return wantarray?@data:$data[0];
371 lockreadbug($bug_num,$location)
373 Performs a filelock, then reads the bug; the bug is unlocked if the
374 return is undefined, otherwise, you need to call unfilelock or
377 See readbug above for information on what this returns
382 my ($lref, $location) = @_;
383 return read_bug(bug => $lref, location => $location, lock => 1);
386 =head2 lockreadbugmerge
388 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
390 Performs a filelock, then reads the bug. If the bug is merged, locks
391 the merge lock. Returns a list of the number of locks and the bug
396 sub lockreadbugmerge {
397 my ($bug_num,$location) = @_;
398 my $data = lockreadbug(@_);
399 if (not defined $data) {
402 if (not length $data->{mergedwith}) {
406 filelock("$config{spool_dir}/lock/merge");
407 $data = lockreadbug(@_);
408 if (not defined $data) {
415 =head2 lock_read_all_merged_bugs
417 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
419 Performs a filelock, then reads the bug passed. If the bug is merged,
420 locks the merge lock, then reads and locks all of the other merged
421 bugs. Returns a list of the number of locks and the bug data for all
424 Will also return undef if any of the merged bugs failed to be read,
425 even if all of the others were read properly.
429 sub lock_read_all_merged_bugs {
430 my ($bug_num,$location) = @_;
432 my @data = (lockreadbug(@_));
433 if (not @data or not defined $data[0]) {
437 if (not length $data[0]->{mergedwith}) {
438 return ($locks,@data);
442 filelock("$config{spool_dir}/lock/merge");
444 @data = (lockreadbug(@_));
445 if (not @data or not defined $data[0]) {
446 unfilelock(); #for merge lock above
451 my @bugs = split / /, $data[0]->{mergedwith};
452 for my $bug (@bugs) {
454 if ($bug ne $bug_num) {
455 $newdata = lockreadbug($bug,$location);
456 if (not defined $newdata) {
461 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
467 # perform a sanity check to make sure that the merged bugs are
468 # all merged with eachother
469 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
470 if ($newdata->{mergedwith} ne $expectmerge) {
474 die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
477 return ($locks,@data);
481 my @v1fieldorder = qw(originator date subject msgid package
482 keywords done forwarded mergedwith severity);
486 my $content = makestatus($status,$version)
487 my $content = makestatus($status);
489 Creates the content for a status file based on the $status hashref
492 Really only useful for writebug
494 Currently defaults to version 2 (non-encoded rfc1522 names) but will
495 eventually default to version 3. If you care, you should specify a
501 my ($data,$version) = @_;
502 $version = 2 unless defined $version;
506 my %newdata = %$data;
507 for my $field (qw(found fixed)) {
508 if (exists $newdata{$field}) {
509 $newdata{"${field}_date"} =
510 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
513 %newdata = %{join_status_fields(\%newdata)};
516 for my $field (@rfc1522_fields) {
517 $newdata{$field} = encode_rfc1522($newdata{$field});
522 for my $field (@v1fieldorder) {
523 if (exists $newdata{$field} and defined $newdata{$field}) {
524 $contents .= "$newdata{$field}\n";
529 } elsif ($version == 2 or $version == 3) {
530 # Version 2 or 3. Add a file format version number for the sake of
531 # further extensibility in the future.
532 $contents .= "Format-Version: $version\n";
533 for my $field (keys %fields) {
534 if (exists $newdata{$field} and defined $newdata{$field}
535 and $newdata{$field} ne '') {
536 # Output field names in proper case, e.g. 'Merged-With'.
537 my $properfield = $fields{$field};
538 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
539 $contents .= "$properfield: $newdata{$field}\n";
549 writebug($bug_num,$status,$location,$minversion,$disablebughook)
551 Writes the bug status and summary files out.
553 Skips writting out a status file if minversion is 2
555 Does not call bughook if disablebughook is true.
560 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
563 my %outputs = (1 => 'status', 2 => 'summary');
564 for my $version (keys %outputs) {
565 next if defined $minversion and $version < $minversion;
566 my $status = getbugcomponent($ref, $outputs{$version}, $location);
567 die "can't find location for $ref" unless defined $status;
568 open(S,"> $status.new") || die "opening $status.new: $!";
569 print(S makestatus($data, $version)) ||
570 die "writing $status.new: $!";
571 close(S) || die "closing $status.new: $!";
577 rename("$status.new",$status) || die "installing new $status: $!";
580 # $disablebughook is a bit of a hack to let format migration scripts use
581 # this function rather than having to duplicate it themselves.
582 &bughook($change,$ref,$data) unless $disablebughook;
585 =head2 unlockwritebug
587 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
589 Writes a bug, then calls unfilelock; see writebug for what these
601 The following functions are exported with the :versions tag
603 =head2 addfoundversions
605 addfoundversions($status,$package,$version,$isbinary);
612 sub addfoundversions {
616 my $isbinary = shift;
617 return unless defined $version;
618 undef $package if $package =~ m[(?:\s|/)];
619 my $source = $package;
621 if (defined $package and $isbinary) {
622 my @srcinfo = binarytosource($package, $version, undef);
624 # We know the source package(s). Use a fully-qualified version.
625 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
628 # Otherwise, an unqualified version will have to do.
632 # Strip off various kinds of brain-damage.
634 $version =~ s/ *\(.*\)//;
635 $version =~ s/ +[A-Za-z].*//;
637 foreach my $ver (split /[,\s]+/, $version) {
638 my $sver = defined($source) ? "$source/$ver" : '';
639 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
640 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
642 @{$data->{fixed_versions}} =
643 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
647 =head2 removefoundversions
649 removefoundversions($data,$package,$versiontoremove)
651 Removes found versions from $data
653 If a version is fully qualified (contains /) only versions matching
654 exactly are removed. Otherwise, all versions matching the version
657 Currently $package and $isbinary are entirely ignored, but accepted
658 for backwards compatibilty.
662 sub removefoundversions {
666 my $isbinary = shift;
667 return unless defined $version;
669 foreach my $ver (split /[,\s]+/, $version) {
671 # fully qualified version
672 @{$data->{found_versions}} =
674 @{$data->{found_versions}};
677 # non qualified version; delete all matchers
678 @{$data->{found_versions}} =
679 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
680 @{$data->{found_versions}};
686 sub addfixedversions {
690 my $isbinary = shift;
691 return unless defined $version;
692 undef $package if defined $package and $package =~ m[(?:\s|/)];
693 my $source = $package;
695 if (defined $package and $isbinary) {
696 my @srcinfo = binarytosource($package, $version, undef);
698 # We know the source package(s). Use a fully-qualified version.
699 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
702 # Otherwise, an unqualified version will have to do.
706 # Strip off various kinds of brain-damage.
708 $version =~ s/ *\(.*\)//;
709 $version =~ s/ +[A-Za-z].*//;
711 foreach my $ver (split /[,\s]+/, $version) {
712 my $sver = defined($source) ? "$source/$ver" : '';
713 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
714 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
716 @{$data->{found_versions}} =
717 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
721 sub removefixedversions {
725 my $isbinary = shift;
726 return unless defined $version;
728 foreach my $ver (split /[,\s]+/, $version) {
730 # fully qualified version
731 @{$data->{fixed_versions}} =
733 @{$data->{fixed_versions}};
736 # non qualified version; delete all matchers
737 @{$data->{fixed_versions}} =
738 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
739 @{$data->{fixed_versions}};
750 Split a package string from the status file into a list of package names.
756 return unless defined $pkgs;
757 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
761 =head2 bug_archiveable
763 bug_archiveable(bug => $bug_num);
769 =item bug -- bug number (required)
771 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
773 =item version -- Debbugs::Version information (optional)
775 =item days_until -- return days until the bug can be archived
779 Returns 1 if the bug can be archived
780 Returns 0 if the bug cannot be archived
782 If days_until is true, returns the number of days until the bug can be
783 archived, -1 if it cannot be archived. 0 means that the bug can be
784 archived the next time the archiver runs.
786 Returns undef on failure.
790 # This will eventually need to be fixed before we start using mod_perl
791 our $version_cache = {};
793 my %param = validate_with(params => \@_,
794 spec => {bug => {type => SCALAR,
797 status => {type => HASHREF,
800 days_until => {type => BOOLEAN,
803 ignore_time => {type => BOOLEAN,
808 # This is what we return if the bug cannot be archived.
809 my $cannot_archive = $param{days_until}?-1:0;
810 # read the status information
811 my $status = $param{status};
812 if (not exists $param{status} or not defined $status) {
813 $status = read_bug(bug=>$param{bug});
814 if (not defined $status) {
815 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
819 # Bugs can be archived if they are
821 if (not defined $status->{done} or not length $status->{done}) {
822 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
823 return $cannot_archive
825 # Check to make sure that the bug has none of the unremovable tags set
826 if (@{$config{removal_unremovable_tags}}) {
827 for my $tag (split ' ', ($status->{tags}||'')) {
828 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
829 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
830 return $cannot_archive;
835 # If we just are checking if the bug can be archived, we'll not even bother
836 # checking the versioning information if the bug has been -done for less than 28 days.
837 my $log_file = getbugcomponent($param{bug},'log');
838 if (not defined $log_file) {
839 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
840 return $cannot_archive;
842 my $max_log_age = max(map {$config{remove_age} - -M $_}
843 $log_file, map {my $log = getbugcomponent($_,'log');
844 defined $log ? ($log) : ();
846 split / /, $status->{mergedwith}
848 if (not $param{days_until} and not $param{ignore_time}
851 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
852 return $cannot_archive;
854 # At this point, we have to get the versioning information for this bug.
855 # We examine the set of distribution tags. If a bug has no distribution
856 # tags set, we assume a default set, otherwise we use the tags the bug
859 # In cases where we are assuming a default set, if the severity
860 # is strong, we use the strong severity default; otherwise, we
861 # use the normal default.
863 # There must be fixed_versions for us to look at the versioning
865 my $min_fixed_time = time;
866 my $min_archive_days = 0;
867 if (@{$status->{fixed_versions}}) {
869 @dist_tags{@{$config{removal_distribution_tags}}} =
870 (1) x @{$config{removal_distribution_tags}};
872 for my $tag (split ' ', ($status->{tags}||'')) {
873 next unless exists $config{distribution_aliases}{$tag};
874 next unless $dist_tags{$config{distribution_aliases}{$tag}};
875 $dists{$config{distribution_aliases}{$tag}} = 1;
877 if (not keys %dists) {
878 if (isstrongseverity($status->{severity})) {
879 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
880 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
883 @dists{@{$config{removal_default_distribution_tags}}} =
884 (1) x @{$config{removal_default_distribution_tags}};
888 my @sourceversions = get_versions(package => $status->{package},
889 dist => [keys %dists],
892 @source_versions{@sourceversions} = (1) x @sourceversions;
893 # If the bug has not been fixed in the versions actually
894 # distributed, then it cannot be archived.
895 if ('found' eq max_buggy(bug => $param{bug},
896 sourceversions => [keys %source_versions],
897 found => $status->{found_versions},
898 fixed => $status->{fixed_versions},
899 version_cache => $version_cache,
900 package => $status->{package},
902 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
903 return $cannot_archive;
905 # Since the bug has at least been fixed in the architectures
906 # that matters, we check to see how long it has been fixed.
908 # If $param{ignore_time}, then we should ignore time.
909 if ($param{ignore_time}) {
910 return $param{days_until}?0:1;
913 # To do this, we order the times from most recent to oldest;
914 # when we come to the first found version, we stop.
915 # If we run out of versions, we only report the time of the
917 my %time_versions = get_versions(package => $status->{package},
918 dist => [keys %dists],
922 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
923 my $buggy = buggy(bug => $param{bug},
925 found => $status->{found_versions},
926 fixed => $status->{fixed_versions},
927 version_cache => $version_cache,
928 package => $status->{package},
930 last if $buggy eq 'found';
931 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
933 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
934 # if there are no versions in the archive at all, then
935 # we can archive if enough days have passed
938 # If $param{ignore_time}, then we should ignore time.
939 if ($param{ignore_time}) {
940 return $param{days_until}?0:1;
942 # 6. at least 28 days have passed since the last action has occured or the bug was closed
943 my $age = ceil($max_log_age);
944 if ($age > 0 or $min_archive_days > 0) {
945 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
946 return $param{days_until}?max($age,$min_archive_days):0;
949 return $param{days_until}?0:1;
954 =head2 get_bug_status
956 my $status = get_bug_status(bug => $nnn);
958 my $status = get_bug_status($bug_num)
964 =item bug -- scalar bug number
966 =item status -- optional hashref of bug status as returned by readbug
967 (can be passed to avoid rereading the bug information)
969 =item bug_index -- optional tied index of bug status infomration;
970 currently not correctly implemented.
972 =item version -- optional version(s) to check package status at
974 =item dist -- optional distribution(s) to check package status at
976 =item arch -- optional architecture(s) to check package status at
978 =item bugusertags -- optional hashref of bugusertags
980 =item sourceversion -- optional arrayref of source/version; overrides
981 dist, arch, and version. [The entries in this array must be in the
982 "source/version" format.] Eventually this can be used to for caching.
984 =item indicatesource -- if true, indicate which source packages this
985 bug could belong to (or does belong to in the case of bugs assigned to
986 a source package). Defaults to true.
990 Note: Currently the version information is cached; this needs to be
991 changed before using this function in long lived programs.
999 my %param = validate_with(params => \@_,
1000 spec => {bug => {type => SCALAR,
1003 status => {type => HASHREF,
1006 bug_index => {type => OBJECT,
1009 version => {type => SCALAR|ARRAYREF,
1012 dist => {type => SCALAR|ARRAYREF,
1015 arch => {type => SCALAR|ARRAYREF,
1018 bugusertags => {type => HASHREF,
1021 sourceversions => {type => ARRAYREF,
1024 indicatesource => {type => BOOLEAN,
1031 if (defined $param{bug_index} and
1032 exists $param{bug_index}{$param{bug}}) {
1033 %status = %{ $param{bug_index}{$param{bug}} };
1034 $status{pending} = $status{ status };
1035 $status{id} = $param{bug};
1038 if (defined $param{status}) {
1039 %status = %{$param{status}};
1042 my $location = getbuglocation($param{bug}, 'summary');
1043 return {} if not defined $location or not length $location;
1044 %status = %{ readbug( $param{bug}, $location ) };
1046 $status{id} = $param{bug};
1048 if (defined $param{bugusertags}{$param{bug}}) {
1049 $status{keywords} = "" unless defined $status{keywords};
1050 $status{keywords} .= " " unless $status{keywords} eq "";
1051 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1053 $status{tags} = $status{keywords};
1054 my %tags = map { $_ => 1 } split ' ', $status{tags};
1056 $status{package} = '' if not defined $status{package};
1057 $status{"package"} =~ s/\s*$//;
1058 # if we aren't supposed to indicate the source, we'll return
1060 $status{source} = 'unknown';
1061 if ($param{indicatesource}) {
1062 my @packages = split /\s*,\s*/, $status{package};
1064 for my $package (@packages) {
1065 next if $package eq '';
1066 if ($package =~ /^src\:$/) {
1070 push @source, binarytosource($package);
1074 $status{source} = join(', ',@source);
1078 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1079 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1081 $status{"pending"} = 'pending';
1082 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1083 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1084 $status{"pending"} = 'fixed' if ($tags{fixed});
1087 my $presence = bug_presence(status => \%status,
1088 map{(exists $param{$_})?($_,$param{$_}):()}
1089 qw(bug sourceversions arch dist version found fixed package)
1091 if (defined $presence) {
1092 if ($presence eq 'fixed') {
1093 $status{pending} = 'done';
1095 elsif ($presence eq 'absent') {
1096 $status{pending} = 'absent';
1104 my $precence = bug_presence(bug => nnn,
1108 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1109 is found, absent, fixed, or no information is available in the
1110 distribution (dist) and/or architecture (arch) specified.
1117 =item bug -- scalar bug number
1119 =item status -- optional hashref of bug status as returned by readbug
1120 (can be passed to avoid rereading the bug information)
1122 =item bug_index -- optional tied index of bug status infomration;
1123 currently not correctly implemented.
1125 =item version -- optional version to check package status at
1127 =item dist -- optional distribution to check package status at
1129 =item arch -- optional architecture to check package status at
1131 =item sourceversion -- optional arrayref of source/version; overrides
1132 dist, arch, and version. [The entries in this array must be in the
1133 "source/version" format.] Eventually this can be used to for caching.
1140 my %param = validate_with(params => \@_,
1141 spec => {bug => {type => SCALAR,
1144 status => {type => HASHREF,
1147 version => {type => SCALAR|ARRAYREF,
1150 dist => {type => SCALAR|ARRAYREF,
1153 arch => {type => SCALAR|ARRAYREF,
1156 sourceversions => {type => ARRAYREF,
1162 if (defined $param{status}) {
1163 %status = %{$param{status}};
1166 my $location = getbuglocation($param{bug}, 'summary');
1167 return {} if not length $location;
1168 %status = %{ readbug( $param{bug}, $location ) };
1172 my $pseudo_desc = getpseudodesc();
1173 if (not exists $param{sourceversions}) {
1175 # pseudopackages do not have source versions by definition.
1176 if (exists $pseudo_desc->{$status{package}}) {
1179 elsif (defined $param{version}) {
1180 foreach my $arch (make_list($param{arch})) {
1181 for my $package (split /\s*,\s*/, $status{package}) {
1182 my @temp = makesourceversions($package,
1184 make_list($param{version})
1186 @sourceversions{@temp} = (1) x @temp;
1189 } elsif (defined $param{dist}) {
1190 my %affects_distribution_tags;
1191 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1192 (1) x @{$config{affects_distribution_tags}};
1193 my $some_distributions_disallowed = 0;
1194 my %allowed_distributions;
1195 for my $tag (split ' ', ($status{tags}||'')) {
1196 if (exists $config{distribution_aliases}{$tag} and
1197 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1198 $some_distributions_disallowed = 1;
1199 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1201 elsif (exists $affects_distribution_tags{$tag}) {
1202 $some_distributions_disallowed = 1;
1203 $allowed_distributions{$tag} = 1;
1206 my @archs = make_list(exists $param{arch}?$param{arch}:());
1207 GET_SOURCE_VERSIONS:
1208 foreach my $arch (@archs) {
1209 for my $package (split /\s*,\s*/, $status{package}) {
1212 if ($package =~ /^src:(.+)$/) {
1216 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1217 # if some distributions are disallowed,
1218 # and this isn't an allowed
1219 # distribution, then we ignore this
1220 # distribution for the purposees of
1222 if ($some_distributions_disallowed and
1223 not exists $allowed_distributions{$dist}) {
1226 push @versions, get_versions(package => $package,
1228 ($source?(arch => 'source'):
1229 (defined $arch?(arch => $arch):())),
1232 next unless @versions;
1233 my @temp = make_source_versions(package => $package,
1235 versions => \@versions,
1237 @sourceversions{@temp} = (1) x @temp;
1240 # this should really be split out into a subroutine,
1241 # but it'd touch so many things currently, that we fake
1242 # it; it's needed to properly handle bugs which are
1243 # erroneously assigned to the binary package, and we'll
1244 # probably have it go away eventually.
1245 if (not keys %sourceversions) {
1247 goto GET_SOURCE_VERSIONS;
1251 # TODO: This should probably be handled further out for efficiency and
1252 # for more ease of distinguishing between pkg= and src= queries.
1253 # DLA: src= queries should just pass arch=source, and they'll be happy.
1254 @sourceversions = keys %sourceversions;
1257 @sourceversions = @{$param{sourceversions}};
1259 my $maxbuggy = 'undef';
1260 if (@sourceversions) {
1261 $maxbuggy = max_buggy(bug => $param{bug},
1262 sourceversions => \@sourceversions,
1263 found => $status{found_versions},
1264 fixed => $status{fixed_versions},
1265 package => $status{package},
1266 version_cache => $version_cache,
1269 elsif (defined $param{dist} and
1270 not exists $pseudo_desc->{$status{package}}) {
1273 if (length($status{done}) and
1274 (not @sourceversions or not @{$status{fixed_versions}})) {
1289 =item bug -- scalar bug number
1291 =item sourceversion -- optional arrayref of source/version; overrides
1292 dist, arch, and version. [The entries in this array must be in the
1293 "source/version" format.] Eventually this can be used to for caching.
1297 Note: Currently the version information is cached; this needs to be
1298 changed before using this function in long lived programs.
1303 my %param = validate_with(params => \@_,
1304 spec => {bug => {type => SCALAR,
1307 sourceversions => {type => ARRAYREF,
1310 found => {type => ARRAYREF,
1313 fixed => {type => ARRAYREF,
1316 package => {type => SCALAR,
1318 version_cache => {type => HASHREF,
1323 # Resolve bugginess states (we might be looking at multiple
1324 # architectures, say). Found wins, then fixed, then absent.
1325 my $maxbuggy = 'absent';
1326 for my $package (split /\s*,\s*/, $param{package}) {
1327 for my $version (@{$param{sourceversions}}) {
1328 my $buggy = buggy(bug => $param{bug},
1329 version => $version,
1330 found => $param{found},
1331 fixed => $param{fixed},
1332 version_cache => $param{version_cache},
1333 package => $package,
1335 if ($buggy eq 'found') {
1337 } elsif ($buggy eq 'fixed') {
1338 $maxbuggy = 'fixed';
1355 Returns the output of Debbugs::Versions::buggy for a particular
1356 package, version and found/fixed set. Automatically turns found, fixed
1357 and version into source/version strings.
1359 Caching can be had by using the version_cache, but no attempt to check
1360 to see if the on disk information is more recent than the cache is
1361 made. [This will need to be fixed for long-lived processes.]
1366 my %param = validate_with(params => \@_,
1367 spec => {bug => {type => SCALAR,
1370 found => {type => ARRAYREF,
1373 fixed => {type => ARRAYREF,
1376 version_cache => {type => HASHREF,
1379 package => {type => SCALAR,
1381 version => {type => SCALAR,
1385 my @found = @{$param{found}};
1386 my @fixed = @{$param{fixed}};
1387 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1388 # We have non-source version versions
1389 @found = makesourceversions($param{package},undef,
1392 @fixed = makesourceversions($param{package},undef,
1396 if ($param{version} !~ m{/}) {
1397 my ($version) = makesourceversions($param{package},undef,
1400 $param{version} = $version if defined $version;
1402 # Figure out which source packages we need
1404 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1405 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1406 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1407 $param{version} =~ m{/};
1409 if (not defined $param{version_cache} or
1410 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1411 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1412 foreach my $source (keys %sources) {
1413 my $srchash = substr $source, 0, 1;
1414 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1415 if (not defined $version_fh) {
1416 # We only want to warn if it's a package which actually has a maintainer
1417 my $maints = getmaintainers();
1418 next if not exists $maints->{$source};
1419 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1422 $version->load($version_fh);
1424 if (defined $param{version_cache}) {
1425 $param{version_cache}{join(',',sort keys %sources)} = $version;
1429 $version = $param{version_cache}{join(',',sort keys %sources)};
1431 return $version->buggy($param{version},\@found,\@fixed);
1434 sub isstrongseverity {
1435 my $severity = shift;
1436 $severity = $config{default_severity} if
1437 not defined $severity or $severity eq '';
1438 return grep { $_ eq $severity } @{$config{strong_severities}};
1442 =head1 PRIVATE FUNCTIONS
1446 sub update_realtime {
1447 my ($file, %bugs) = @_;
1449 # update realtime index.db
1451 return () unless keys %bugs;
1452 my $idx_old = IO::File->new($file,'r')
1453 or die "Couldn't open ${file}: $!";
1454 my $idx_new = IO::File->new($file.'.new','w')
1455 or die "Couldn't open ${file}.new: $!";
1457 my $min_bug = min(keys %bugs);
1461 while($line = <$idx_old>) {
1462 @line = split /\s/, $line;
1463 # Two cases; replacing existing line or adding new line
1464 if (exists $bugs{$line[1]}) {
1465 my $new = $bugs{$line[1]};
1466 delete $bugs{$line[1]};
1467 $min_bug = min(keys %bugs);
1468 if ($new eq "NOCHANGE") {
1469 print {$idx_new} $line;
1470 $changed_bugs{$line[1]} = $line;
1471 } elsif ($new eq "REMOVE") {
1472 $changed_bugs{$line[1]} = $line;
1474 print {$idx_new} $new;
1475 $changed_bugs{$line[1]} = $line;
1479 while ($line[1] > $min_bug) {
1480 print {$idx_new} $bugs{$min_bug};
1481 delete $bugs{$min_bug};
1482 last unless keys %bugs;
1483 $min_bug = min(keys %bugs);
1485 print {$idx_new} $line;
1487 last unless keys %bugs;
1489 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1491 print {$idx_new} <$idx_old>;
1496 rename("$file.new", $file);
1498 return %changed_bugs;
1501 sub bughook_archive {
1503 &filelock("$config{spool_dir}/debbugs.trace.lock");
1504 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1505 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1506 map{($_,'REMOVE')} @refs);
1507 update_realtime("$config{spool_dir}/index.archive.realtime",
1513 my ( $type, %bugs_temp ) = @_;
1514 &filelock("$config{spool_dir}/debbugs.trace.lock");
1517 for my $bug (keys %bugs_temp) {
1518 my $data = $bugs_temp{$bug};
1519 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1521 my $whendone = "open";
1522 my $severity = $config{default_severity};
1523 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1524 $pkglist =~ s/^,+//;
1525 $pkglist =~ s/,+$//;
1526 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1527 $whendone = "done" if defined $data->{done} and length $data->{done};
1528 $severity = $data->{severity} if length $data->{severity};
1530 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1531 $pkglist, $bug, $data->{date}, $whendone,
1532 $data->{originator}, $severity, $data->{keywords};
1535 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);