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 # this isn't strictly correct, but we'll split both of them for
295 # the time being until we ditch all use of keywords everywhere
297 keywords => $ditch_empty_space,
298 tags => $ditch_empty_space,
299 found_versions => $ditch_empty_space,
300 fixed_versions => $ditch_empty_space,
301 mergedwith => $ditch_empty_space,
304 sub split_status_fields {
305 my @data = @{dclone(\@_)};
306 for my $data (@data) {
307 next if not defined $data;
308 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
309 not (ref($data) and ref($data) eq 'HASH');
310 for my $field (keys %{$data}) {
311 next unless defined $data->{$field};
312 if (exists $split_fields{$field}) {
313 next if ref($data->{$field});
315 if (ref($split_fields{$field}) eq 'CODE') {
316 @elements = &{$split_fields{$field}}($data->{$field});
318 elsif (not ref($split_fields{$field}) or
319 UNIVERSAL::isa($split_fields{$field},'Regex')
321 @elements = split $split_fields{$field}, $data->{$field};
323 $data->{$field} = \@elements;
327 return wantarray?@data:$data[0];
330 =head2 join_status_fields
332 my @data = join_status_fields(@data);
334 Handles joining the splitable status fields. (Basically, the inverse
335 of split_status_fields.
337 Primarily called from makestatus, but may be useful for other
338 functions after calling split_status_fields (or for legacy functions
339 if we transition to split fields by default).
343 sub join_status_fields {
350 found_versions => ' ',
351 fixed_versions => ' ',
356 my @data = @{dclone(\@_)};
357 for my $data (@data) {
358 next if not defined $data;
359 croak "Passed an element which is not a hashref to split_status_field: ".
361 if ref($data) ne 'HASH';
362 for my $field (keys %{$data}) {
363 next unless defined $data->{$field};
364 next unless ref($data->{$field}) eq 'ARRAY';
365 next unless exists $join_fields{$field};
366 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
369 return wantarray?@data:$data[0];
375 lockreadbug($bug_num,$location)
377 Performs a filelock, then reads the bug; the bug is unlocked if the
378 return is undefined, otherwise, you need to call unfilelock or
381 See readbug above for information on what this returns
386 my ($lref, $location) = @_;
387 return read_bug(bug => $lref, location => $location, lock => 1);
390 =head2 lockreadbugmerge
392 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
394 Performs a filelock, then reads the bug. If the bug is merged, locks
395 the merge lock. Returns a list of the number of locks and the bug
400 sub lockreadbugmerge {
401 my ($bug_num,$location) = @_;
402 my $data = lockreadbug(@_);
403 if (not defined $data) {
406 if (not length $data->{mergedwith}) {
410 filelock("$config{spool_dir}/lock/merge");
411 $data = lockreadbug(@_);
412 if (not defined $data) {
419 =head2 lock_read_all_merged_bugs
421 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
423 Performs a filelock, then reads the bug passed. If the bug is merged,
424 locks the merge lock, then reads and locks all of the other merged
425 bugs. Returns a list of the number of locks and the bug data for all
428 Will also return undef if any of the merged bugs failed to be read,
429 even if all of the others were read properly.
433 sub lock_read_all_merged_bugs {
434 my ($bug_num,$location) = @_;
436 my @data = (lockreadbug(@_));
437 if (not @data or not defined $data[0]) {
441 if (not length $data[0]->{mergedwith}) {
442 return ($locks,@data);
446 filelock("$config{spool_dir}/lock/merge");
448 @data = (lockreadbug(@_));
449 if (not @data or not defined $data[0]) {
450 unfilelock(); #for merge lock above
455 my @bugs = split / /, $data[0]->{mergedwith};
456 for my $bug (@bugs) {
458 if ($bug ne $bug_num) {
459 $newdata = lockreadbug($bug,$location);
460 if (not defined $newdata) {
465 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
471 # perform a sanity check to make sure that the merged bugs are
472 # all merged with eachother
473 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
474 if ($newdata->{mergedwith} ne $expectmerge) {
478 die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
481 return ($locks,@data);
485 my @v1fieldorder = qw(originator date subject msgid package
486 keywords done forwarded mergedwith severity);
490 my $content = makestatus($status,$version)
491 my $content = makestatus($status);
493 Creates the content for a status file based on the $status hashref
496 Really only useful for writebug
498 Currently defaults to version 2 (non-encoded rfc1522 names) but will
499 eventually default to version 3. If you care, you should specify a
505 my ($data,$version) = @_;
506 $version = 2 unless defined $version;
510 my %newdata = %$data;
511 for my $field (qw(found fixed)) {
512 if (exists $newdata{$field}) {
513 $newdata{"${field}_date"} =
514 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
517 %newdata = %{join_status_fields(\%newdata)};
520 for my $field (@rfc1522_fields) {
521 $newdata{$field} = encode_rfc1522($newdata{$field});
526 for my $field (@v1fieldorder) {
527 if (exists $newdata{$field} and defined $newdata{$field}) {
528 $contents .= "$newdata{$field}\n";
533 } elsif ($version == 2 or $version == 3) {
534 # Version 2 or 3. Add a file format version number for the sake of
535 # further extensibility in the future.
536 $contents .= "Format-Version: $version\n";
537 for my $field (keys %fields) {
538 if (exists $newdata{$field} and defined $newdata{$field}
539 and $newdata{$field} ne '') {
540 # Output field names in proper case, e.g. 'Merged-With'.
541 my $properfield = $fields{$field};
542 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
543 $contents .= "$properfield: $newdata{$field}\n";
553 writebug($bug_num,$status,$location,$minversion,$disablebughook)
555 Writes the bug status and summary files out.
557 Skips writting out a status file if minversion is 2
559 Does not call bughook if disablebughook is true.
564 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
567 my %outputs = (1 => 'status', 2 => 'summary');
568 for my $version (keys %outputs) {
569 next if defined $minversion and $version < $minversion;
570 my $status = getbugcomponent($ref, $outputs{$version}, $location);
571 die "can't find location for $ref" unless defined $status;
572 open(S,"> $status.new") || die "opening $status.new: $!";
573 print(S makestatus($data, $version)) ||
574 die "writing $status.new: $!";
575 close(S) || die "closing $status.new: $!";
581 rename("$status.new",$status) || die "installing new $status: $!";
584 # $disablebughook is a bit of a hack to let format migration scripts use
585 # this function rather than having to duplicate it themselves.
586 &bughook($change,$ref,$data) unless $disablebughook;
589 =head2 unlockwritebug
591 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
593 Writes a bug, then calls unfilelock; see writebug for what these
605 The following functions are exported with the :versions tag
607 =head2 addfoundversions
609 addfoundversions($status,$package,$version,$isbinary);
616 sub addfoundversions {
620 my $isbinary = shift;
621 return unless defined $version;
622 undef $package if $package =~ m[(?:\s|/)];
623 my $source = $package;
625 if (defined $package and $isbinary) {
626 my @srcinfo = binarytosource($package, $version, undef);
628 # We know the source package(s). Use a fully-qualified version.
629 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
632 # Otherwise, an unqualified version will have to do.
636 # Strip off various kinds of brain-damage.
638 $version =~ s/ *\(.*\)//;
639 $version =~ s/ +[A-Za-z].*//;
641 foreach my $ver (split /[,\s]+/, $version) {
642 my $sver = defined($source) ? "$source/$ver" : '';
643 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
644 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
646 @{$data->{fixed_versions}} =
647 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
651 =head2 removefoundversions
653 removefoundversions($data,$package,$versiontoremove)
655 Removes found versions from $data
657 If a version is fully qualified (contains /) only versions matching
658 exactly are removed. Otherwise, all versions matching the version
661 Currently $package and $isbinary are entirely ignored, but accepted
662 for backwards compatibilty.
666 sub removefoundversions {
670 my $isbinary = shift;
671 return unless defined $version;
673 foreach my $ver (split /[,\s]+/, $version) {
675 # fully qualified version
676 @{$data->{found_versions}} =
678 @{$data->{found_versions}};
681 # non qualified version; delete all matchers
682 @{$data->{found_versions}} =
683 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
684 @{$data->{found_versions}};
690 sub addfixedversions {
694 my $isbinary = shift;
695 return unless defined $version;
696 undef $package if defined $package and $package =~ m[(?:\s|/)];
697 my $source = $package;
699 if (defined $package and $isbinary) {
700 my @srcinfo = binarytosource($package, $version, undef);
702 # We know the source package(s). Use a fully-qualified version.
703 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
706 # Otherwise, an unqualified version will have to do.
710 # Strip off various kinds of brain-damage.
712 $version =~ s/ *\(.*\)//;
713 $version =~ s/ +[A-Za-z].*//;
715 foreach my $ver (split /[,\s]+/, $version) {
716 my $sver = defined($source) ? "$source/$ver" : '';
717 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
718 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
720 @{$data->{found_versions}} =
721 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
725 sub removefixedversions {
729 my $isbinary = shift;
730 return unless defined $version;
732 foreach my $ver (split /[,\s]+/, $version) {
734 # fully qualified version
735 @{$data->{fixed_versions}} =
737 @{$data->{fixed_versions}};
740 # non qualified version; delete all matchers
741 @{$data->{fixed_versions}} =
742 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
743 @{$data->{fixed_versions}};
754 Split a package string from the status file into a list of package names.
760 return unless defined $pkgs;
761 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
765 =head2 bug_archiveable
767 bug_archiveable(bug => $bug_num);
773 =item bug -- bug number (required)
775 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
777 =item version -- Debbugs::Version information (optional)
779 =item days_until -- return days until the bug can be archived
783 Returns 1 if the bug can be archived
784 Returns 0 if the bug cannot be archived
786 If days_until is true, returns the number of days until the bug can be
787 archived, -1 if it cannot be archived. 0 means that the bug can be
788 archived the next time the archiver runs.
790 Returns undef on failure.
794 # This will eventually need to be fixed before we start using mod_perl
795 our $version_cache = {};
797 my %param = validate_with(params => \@_,
798 spec => {bug => {type => SCALAR,
801 status => {type => HASHREF,
804 days_until => {type => BOOLEAN,
807 ignore_time => {type => BOOLEAN,
812 # This is what we return if the bug cannot be archived.
813 my $cannot_archive = $param{days_until}?-1:0;
814 # read the status information
815 my $status = $param{status};
816 if (not exists $param{status} or not defined $status) {
817 $status = read_bug(bug=>$param{bug});
818 if (not defined $status) {
819 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
823 # Bugs can be archived if they are
825 if (not defined $status->{done} or not length $status->{done}) {
826 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
827 return $cannot_archive
829 # Check to make sure that the bug has none of the unremovable tags set
830 if (@{$config{removal_unremovable_tags}}) {
831 for my $tag (split ' ', ($status->{tags}||'')) {
832 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
833 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
834 return $cannot_archive;
839 # If we just are checking if the bug can be archived, we'll not even bother
840 # checking the versioning information if the bug has been -done for less than 28 days.
841 my $log_file = getbugcomponent($param{bug},'log');
842 if (not defined $log_file) {
843 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
844 return $cannot_archive;
846 my $max_log_age = max(map {$config{remove_age} - -M $_}
847 $log_file, map {my $log = getbugcomponent($_,'log');
848 defined $log ? ($log) : ();
850 split / /, $status->{mergedwith}
852 if (not $param{days_until} and not $param{ignore_time}
855 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
856 return $cannot_archive;
858 # At this point, we have to get the versioning information for this bug.
859 # We examine the set of distribution tags. If a bug has no distribution
860 # tags set, we assume a default set, otherwise we use the tags the bug
863 # In cases where we are assuming a default set, if the severity
864 # is strong, we use the strong severity default; otherwise, we
865 # use the normal default.
867 # There must be fixed_versions for us to look at the versioning
869 my $min_fixed_time = time;
870 my $min_archive_days = 0;
871 if (@{$status->{fixed_versions}}) {
873 @dist_tags{@{$config{removal_distribution_tags}}} =
874 (1) x @{$config{removal_distribution_tags}};
876 for my $tag (split ' ', ($status->{tags}||'')) {
877 next unless exists $config{distribution_aliases}{$tag};
878 next unless $dist_tags{$config{distribution_aliases}{$tag}};
879 $dists{$config{distribution_aliases}{$tag}} = 1;
881 if (not keys %dists) {
882 if (isstrongseverity($status->{severity})) {
883 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
884 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
887 @dists{@{$config{removal_default_distribution_tags}}} =
888 (1) x @{$config{removal_default_distribution_tags}};
892 my @sourceversions = get_versions(package => $status->{package},
893 dist => [keys %dists],
896 @source_versions{@sourceversions} = (1) x @sourceversions;
897 # If the bug has not been fixed in the versions actually
898 # distributed, then it cannot be archived.
899 if ('found' eq max_buggy(bug => $param{bug},
900 sourceversions => [keys %source_versions],
901 found => $status->{found_versions},
902 fixed => $status->{fixed_versions},
903 version_cache => $version_cache,
904 package => $status->{package},
906 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
907 return $cannot_archive;
909 # Since the bug has at least been fixed in the architectures
910 # that matters, we check to see how long it has been fixed.
912 # If $param{ignore_time}, then we should ignore time.
913 if ($param{ignore_time}) {
914 return $param{days_until}?0:1;
917 # To do this, we order the times from most recent to oldest;
918 # when we come to the first found version, we stop.
919 # If we run out of versions, we only report the time of the
921 my %time_versions = get_versions(package => $status->{package},
922 dist => [keys %dists],
926 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
927 my $buggy = buggy(bug => $param{bug},
929 found => $status->{found_versions},
930 fixed => $status->{fixed_versions},
931 version_cache => $version_cache,
932 package => $status->{package},
934 last if $buggy eq 'found';
935 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
937 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
938 # if there are no versions in the archive at all, then
939 # we can archive if enough days have passed
942 # If $param{ignore_time}, then we should ignore time.
943 if ($param{ignore_time}) {
944 return $param{days_until}?0:1;
946 # 6. at least 28 days have passed since the last action has occured or the bug was closed
947 my $age = ceil($max_log_age);
948 if ($age > 0 or $min_archive_days > 0) {
949 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
950 return $param{days_until}?max($age,$min_archive_days):0;
953 return $param{days_until}?0:1;
958 =head2 get_bug_status
960 my $status = get_bug_status(bug => $nnn);
962 my $status = get_bug_status($bug_num)
968 =item bug -- scalar bug number
970 =item status -- optional hashref of bug status as returned by readbug
971 (can be passed to avoid rereading the bug information)
973 =item bug_index -- optional tied index of bug status infomration;
974 currently not correctly implemented.
976 =item version -- optional version(s) to check package status at
978 =item dist -- optional distribution(s) to check package status at
980 =item arch -- optional architecture(s) to check package status at
982 =item bugusertags -- optional hashref of bugusertags
984 =item sourceversion -- optional arrayref of source/version; overrides
985 dist, arch, and version. [The entries in this array must be in the
986 "source/version" format.] Eventually this can be used to for caching.
988 =item indicatesource -- if true, indicate which source packages this
989 bug could belong to (or does belong to in the case of bugs assigned to
990 a source package). Defaults to true.
994 Note: Currently the version information is cached; this needs to be
995 changed before using this function in long lived programs.
1003 my %param = validate_with(params => \@_,
1004 spec => {bug => {type => SCALAR,
1007 status => {type => HASHREF,
1010 bug_index => {type => OBJECT,
1013 version => {type => SCALAR|ARRAYREF,
1016 dist => {type => SCALAR|ARRAYREF,
1019 arch => {type => SCALAR|ARRAYREF,
1022 bugusertags => {type => HASHREF,
1025 sourceversions => {type => ARRAYREF,
1028 indicatesource => {type => BOOLEAN,
1035 if (defined $param{bug_index} and
1036 exists $param{bug_index}{$param{bug}}) {
1037 %status = %{ $param{bug_index}{$param{bug}} };
1038 $status{pending} = $status{ status };
1039 $status{id} = $param{bug};
1042 if (defined $param{status}) {
1043 %status = %{$param{status}};
1046 my $location = getbuglocation($param{bug}, 'summary');
1047 return {} if not defined $location or not length $location;
1048 %status = %{ readbug( $param{bug}, $location ) };
1050 $status{id} = $param{bug};
1052 if (defined $param{bugusertags}{$param{bug}}) {
1053 $status{keywords} = "" unless defined $status{keywords};
1054 $status{keywords} .= " " unless $status{keywords} eq "";
1055 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1057 $status{tags} = $status{keywords};
1058 my %tags = map { $_ => 1 } split ' ', $status{tags};
1060 $status{package} = '' if not defined $status{package};
1061 $status{"package"} =~ s/\s*$//;
1062 # if we aren't supposed to indicate the source, we'll return
1064 $status{source} = 'unknown';
1065 if ($param{indicatesource}) {
1066 my @packages = split /\s*,\s*/, $status{package};
1068 for my $package (@packages) {
1069 next if $package eq '';
1070 if ($package =~ /^src\:(.+)$/) {
1074 push @source, binarytosource($package);
1078 $status{source} = join(', ',@source);
1082 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1083 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1085 $status{"pending"} = 'pending';
1086 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1087 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1088 $status{"pending"} = 'fixed' if ($tags{fixed});
1091 my $presence = bug_presence(status => \%status,
1092 map{(exists $param{$_})?($_,$param{$_}):()}
1093 qw(bug sourceversions arch dist version found fixed package)
1095 if (defined $presence) {
1096 if ($presence eq 'fixed') {
1097 $status{pending} = 'done';
1099 elsif ($presence eq 'absent') {
1100 $status{pending} = 'absent';
1108 my $precence = bug_presence(bug => nnn,
1112 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1113 is found, absent, fixed, or no information is available in the
1114 distribution (dist) and/or architecture (arch) specified.
1121 =item bug -- scalar bug number
1123 =item status -- optional hashref of bug status as returned by readbug
1124 (can be passed to avoid rereading the bug information)
1126 =item bug_index -- optional tied index of bug status infomration;
1127 currently not correctly implemented.
1129 =item version -- optional version to check package status at
1131 =item dist -- optional distribution to check package status at
1133 =item arch -- optional architecture to check package status at
1135 =item sourceversion -- optional arrayref of source/version; overrides
1136 dist, arch, and version. [The entries in this array must be in the
1137 "source/version" format.] Eventually this can be used to for caching.
1144 my %param = validate_with(params => \@_,
1145 spec => {bug => {type => SCALAR,
1148 status => {type => HASHREF,
1151 version => {type => SCALAR|ARRAYREF,
1154 dist => {type => SCALAR|ARRAYREF,
1157 arch => {type => SCALAR|ARRAYREF,
1160 sourceversions => {type => ARRAYREF,
1166 if (defined $param{status}) {
1167 %status = %{$param{status}};
1170 my $location = getbuglocation($param{bug}, 'summary');
1171 return {} if not length $location;
1172 %status = %{ readbug( $param{bug}, $location ) };
1176 my $pseudo_desc = getpseudodesc();
1177 if (not exists $param{sourceversions}) {
1179 # pseudopackages do not have source versions by definition.
1180 if (exists $pseudo_desc->{$status{package}}) {
1183 elsif (defined $param{version}) {
1184 foreach my $arch (make_list($param{arch})) {
1185 for my $package (split /\s*,\s*/, $status{package}) {
1186 my @temp = makesourceversions($package,
1188 make_list($param{version})
1190 @sourceversions{@temp} = (1) x @temp;
1193 } elsif (defined $param{dist}) {
1194 my %affects_distribution_tags;
1195 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1196 (1) x @{$config{affects_distribution_tags}};
1197 my $some_distributions_disallowed = 0;
1198 my %allowed_distributions;
1199 for my $tag (split ' ', ($status{tags}||'')) {
1200 if (exists $config{distribution_aliases}{$tag} and
1201 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1202 $some_distributions_disallowed = 1;
1203 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1205 elsif (exists $affects_distribution_tags{$tag}) {
1206 $some_distributions_disallowed = 1;
1207 $allowed_distributions{$tag} = 1;
1210 my @archs = make_list(exists $param{arch}?$param{arch}:());
1211 GET_SOURCE_VERSIONS:
1212 foreach my $arch (@archs) {
1213 for my $package (split /\s*,\s*/, $status{package}) {
1216 if ($package =~ /^src:(.+)$/) {
1220 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1221 # if some distributions are disallowed,
1222 # and this isn't an allowed
1223 # distribution, then we ignore this
1224 # distribution for the purposees of
1226 if ($some_distributions_disallowed and
1227 not exists $allowed_distributions{$dist}) {
1230 push @versions, get_versions(package => $package,
1232 ($source?(arch => 'source'):
1233 (defined $arch?(arch => $arch):())),
1236 next unless @versions;
1237 my @temp = make_source_versions(package => $package,
1239 versions => \@versions,
1241 @sourceversions{@temp} = (1) x @temp;
1244 # this should really be split out into a subroutine,
1245 # but it'd touch so many things currently, that we fake
1246 # it; it's needed to properly handle bugs which are
1247 # erroneously assigned to the binary package, and we'll
1248 # probably have it go away eventually.
1249 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1251 goto GET_SOURCE_VERSIONS;
1255 # TODO: This should probably be handled further out for efficiency and
1256 # for more ease of distinguishing between pkg= and src= queries.
1257 # DLA: src= queries should just pass arch=source, and they'll be happy.
1258 @sourceversions = keys %sourceversions;
1261 @sourceversions = @{$param{sourceversions}};
1263 my $maxbuggy = 'undef';
1264 if (@sourceversions) {
1265 $maxbuggy = max_buggy(bug => $param{bug},
1266 sourceversions => \@sourceversions,
1267 found => $status{found_versions},
1268 fixed => $status{fixed_versions},
1269 package => $status{package},
1270 version_cache => $version_cache,
1273 elsif (defined $param{dist} and
1274 not exists $pseudo_desc->{$status{package}}) {
1277 if (length($status{done}) and
1278 (not @sourceversions or not @{$status{fixed_versions}})) {
1293 =item bug -- scalar bug number
1295 =item sourceversion -- optional arrayref of source/version; overrides
1296 dist, arch, and version. [The entries in this array must be in the
1297 "source/version" format.] Eventually this can be used to for caching.
1301 Note: Currently the version information is cached; this needs to be
1302 changed before using this function in long lived programs.
1307 my %param = validate_with(params => \@_,
1308 spec => {bug => {type => SCALAR,
1311 sourceversions => {type => ARRAYREF,
1314 found => {type => ARRAYREF,
1317 fixed => {type => ARRAYREF,
1320 package => {type => SCALAR,
1322 version_cache => {type => HASHREF,
1327 # Resolve bugginess states (we might be looking at multiple
1328 # architectures, say). Found wins, then fixed, then absent.
1329 my $maxbuggy = 'absent';
1330 for my $package (split /\s*,\s*/, $param{package}) {
1331 for my $version (@{$param{sourceversions}}) {
1332 my $buggy = buggy(bug => $param{bug},
1333 version => $version,
1334 found => $param{found},
1335 fixed => $param{fixed},
1336 version_cache => $param{version_cache},
1337 package => $package,
1339 if ($buggy eq 'found') {
1341 } elsif ($buggy eq 'fixed') {
1342 $maxbuggy = 'fixed';
1359 Returns the output of Debbugs::Versions::buggy for a particular
1360 package, version and found/fixed set. Automatically turns found, fixed
1361 and version into source/version strings.
1363 Caching can be had by using the version_cache, but no attempt to check
1364 to see if the on disk information is more recent than the cache is
1365 made. [This will need to be fixed for long-lived processes.]
1370 my %param = validate_with(params => \@_,
1371 spec => {bug => {type => SCALAR,
1374 found => {type => ARRAYREF,
1377 fixed => {type => ARRAYREF,
1380 version_cache => {type => HASHREF,
1383 package => {type => SCALAR,
1385 version => {type => SCALAR,
1389 my @found = @{$param{found}};
1390 my @fixed = @{$param{fixed}};
1391 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1392 # We have non-source version versions
1393 @found = makesourceversions($param{package},undef,
1396 @fixed = makesourceversions($param{package},undef,
1400 if ($param{version} !~ m{/}) {
1401 my ($version) = makesourceversions($param{package},undef,
1404 $param{version} = $version if defined $version;
1406 # Figure out which source packages we need
1408 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1409 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1410 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1411 $param{version} =~ m{/};
1413 if (not defined $param{version_cache} or
1414 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1415 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1416 foreach my $source (keys %sources) {
1417 my $srchash = substr $source, 0, 1;
1418 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1419 if (not defined $version_fh) {
1420 # We only want to warn if it's a package which actually has a maintainer
1421 my $maints = getmaintainers();
1422 next if not exists $maints->{$source};
1423 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1426 $version->load($version_fh);
1428 if (defined $param{version_cache}) {
1429 $param{version_cache}{join(',',sort keys %sources)} = $version;
1433 $version = $param{version_cache}{join(',',sort keys %sources)};
1435 return $version->buggy($param{version},\@found,\@fixed);
1438 sub isstrongseverity {
1439 my $severity = shift;
1440 $severity = $config{default_severity} if
1441 not defined $severity or $severity eq '';
1442 return grep { $_ eq $severity } @{$config{strong_severities}};
1446 =head1 PRIVATE FUNCTIONS
1450 sub update_realtime {
1451 my ($file, %bugs) = @_;
1453 # update realtime index.db
1455 return () unless keys %bugs;
1456 my $idx_old = IO::File->new($file,'r')
1457 or die "Couldn't open ${file}: $!";
1458 my $idx_new = IO::File->new($file.'.new','w')
1459 or die "Couldn't open ${file}.new: $!";
1461 my $min_bug = min(keys %bugs);
1465 while($line = <$idx_old>) {
1466 @line = split /\s/, $line;
1467 # Two cases; replacing existing line or adding new line
1468 if (exists $bugs{$line[1]}) {
1469 my $new = $bugs{$line[1]};
1470 delete $bugs{$line[1]};
1471 $min_bug = min(keys %bugs);
1472 if ($new eq "NOCHANGE") {
1473 print {$idx_new} $line;
1474 $changed_bugs{$line[1]} = $line;
1475 } elsif ($new eq "REMOVE") {
1476 $changed_bugs{$line[1]} = $line;
1478 print {$idx_new} $new;
1479 $changed_bugs{$line[1]} = $line;
1483 while ($line[1] > $min_bug) {
1484 print {$idx_new} $bugs{$min_bug};
1485 delete $bugs{$min_bug};
1486 last unless keys %bugs;
1487 $min_bug = min(keys %bugs);
1489 print {$idx_new} $line;
1491 last unless keys %bugs;
1493 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1495 print {$idx_new} <$idx_old>;
1500 rename("$file.new", $file);
1502 return %changed_bugs;
1505 sub bughook_archive {
1507 &filelock("$config{spool_dir}/debbugs.trace.lock");
1508 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1509 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1510 map{($_,'REMOVE')} @refs);
1511 update_realtime("$config{spool_dir}/index.archive.realtime",
1517 my ( $type, %bugs_temp ) = @_;
1518 &filelock("$config{spool_dir}/debbugs.trace.lock");
1521 for my $bug (keys %bugs_temp) {
1522 my $data = $bugs_temp{$bug};
1523 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1525 my $whendone = "open";
1526 my $severity = $config{default_severity};
1527 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1528 $pkglist =~ s/^,+//;
1529 $pkglist =~ s/,+$//;
1530 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1531 $whendone = "done" if defined $data->{done} and length $data->{done};
1532 $severity = $data->{severity} if length $data->{severity};
1534 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1535 $pkglist, $bug, $data->{date}, $whendone,
1536 $data->{originator}, $severity, $data->{keywords};
1539 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);