1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Status;
14 Debbugs::Status -- Routines for dealing with summary and status files
23 This module is a replacement for the parts of errorlib.pl which write
24 and read status and summary files.
26 It also contains generic routines for returning information about the
27 status of a particular bug
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(:util :lock :quit :misc);
41 use Debbugs::Config qw(:config);
42 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
43 use Debbugs::Packages qw(makesourceversions getversions get_versions binarytosource);
44 use Debbugs::Versions;
45 use Debbugs::Versions::Dpkg;
48 use List::Util qw(min max);
53 $DEBUG = 0 unless defined $DEBUG;
56 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
57 qw(isstrongseverity bug_presence),
59 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
60 qw(lock_read_all_merged_bugs),
62 write => [qw(writebug makestatus unlockwritebug)],
63 versions => [qw(addfoundversions addfixedversions),
64 qw(removefoundversions removefixedversions)
66 hook => [qw(bughook bughook_archive)],
69 Exporter::export_ok_tags(qw(status read write versions hook));
70 $EXPORT_TAGS{all} = [@EXPORT_OK];
76 readbug($bug_num,$location)
79 Reads a summary file from the archive given a bug number and a bug
80 location. Valid locations are those understood by L</getbugcomponent>
85 my %fields = (originator => 'submitter',
88 msgid => 'message-id',
89 'package' => 'package',
92 forwarded => 'forwarded-to',
93 mergedwith => 'merged-with',
94 severity => 'severity',
96 found_versions => 'found-in',
97 found_date => 'found-date',
98 fixed_versions => 'fixed-in',
99 fixed_date => 'fixed-date',
101 blockedby => 'blocked-by',
102 unarchived => 'unarchived',
103 summary => 'summary',
104 affects => 'affects',
107 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
108 my @rfc1522_fields = qw(originator subject done forwarded owner);
111 return read_bug(bug => $_[0],
112 (@_ > 1)?(location => $_[1]):()
118 read_bug(bug => $bug_num,
119 location => 'archive',
121 read_bug(summary => 'path/to/bugnum.summary');
124 A more complete function than readbug; it enables you to pass a full
125 path to the summary file instead of the bug number and/or location.
131 =item bug -- the bug number
133 =item location -- optional location which is passed to getbugcomponent
135 =item summary -- complete path to the .summary file which will be read
137 =item lock -- whether to obtain a lock for the bug to prevent
138 something modifying it while the bug has been read. You B<must> call
139 C<unfilelock();> if something not undef is returned from read_bug.
143 One of C<bug> or C<summary> must be passed. This function will return
144 undef on failure, and will die if improper arguments are passed.
152 my %param = validate_with(params => \@_,
153 spec => {bug => {type => SCALAR,
157 # negative bugnumbers
160 location => {type => SCALAR|UNDEF,
163 summary => {type => SCALAR,
166 lock => {type => BOOLEAN,
171 die "One of bug or summary must be passed to read_bug"
172 if not exists $param{bug} and not exists $param{summary};
176 if (not defined $param{summary}) {
178 ($lref,$location) = @param{qw(bug location)};
179 if (not defined $location) {
180 $location = getbuglocation($lref,'summary');
181 return undef if not defined $location;
183 $status = getbugcomponent($lref, 'summary', $location);
184 $log = getbugcomponent($lref, 'log' , $location);
185 return undef unless defined $status;
188 $status = $param{summary};
190 $log =~ s/\.summary$/.log/;
191 ($location) = $status =~ m/(db-h|db|archive)/;
194 filelock("$config{spool_dir}/lock/$param{bug}");
196 my $status_fh = IO::File->new($status, 'r');
197 if (not defined $status_fh) {
198 warn "Unable to open $status for reading: $!";
210 while (<$status_fh>) {
213 $version = $1 if /^Format-Version: ([0-9]+)/i;
216 # Version 3 is the latest format version currently supported.
218 warn "Unsupported status version '$version'";
225 my %namemap = reverse %fields;
226 for my $line (@lines) {
227 if ($line =~ /(\S+?): (.*)/) {
228 my ($name, $value) = (lc $1, $2);
229 $data{$namemap{$name}} = $value if exists $namemap{$name};
232 for my $field (keys %fields) {
233 $data{$field} = '' unless exists $data{$field};
236 $data{severity} = $config{default_severity} if $data{severity} eq '';
237 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
238 $data{$field} = [split ' ', $data{$field}];
240 for my $field (qw(found fixed)) {
241 # create the found/fixed hashes which indicate when a
242 # particular version was marked found or marked fixed.
243 @{$data{$field}}{@{$data{"${field}_versions"}}} =
244 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
245 @{$data{"${field}_date"}});
249 for my $field (@rfc1522_fields) {
250 $data{$field} = decode_rfc1522($data{$field});
253 # Add log last modified time
254 $data{log_modified} = (stat($log))[9];
255 $data{location} = $location;
256 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
257 $data{bug_num} = $param{bug};
264 lockreadbug($bug_num,$location)
266 Performs a filelock, then reads the bug; the bug is unlocked if the
267 return is undefined, otherwise, you need to call unfilelock or
270 See readbug above for information on what this returns
275 my ($lref, $location) = @_;
276 return read_bug(bug => $lref, location => $location, lock => 1);
279 =head2 lockreadbugmerge
281 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
283 Performs a filelock, then reads the bug. If the bug is merged, locks
284 the merge lock. Returns a list of the number of locks and the bug
289 sub lockreadbugmerge {
290 my ($bug_num,$location) = @_;
291 my $data = lockreadbug(@_);
292 if (not defined $data) {
295 if (not length $data->{mergedwith}) {
299 filelock("$config{spool_dir}/lock/merge");
300 $data = lockreadbug(@_);
301 if (not defined $data) {
308 =head2 lock_read_all_merged_bugs
310 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
312 Performs a filelock, then reads the bug passed. If the bug is merged,
313 locks the merge lock, then reads and locks all of the other merged
314 bugs. Returns a list of the number of locks and the bug data for all
317 Will also return undef if any of the merged bugs failed to be read,
318 even if all of the others were read properly.
322 sub lock_read_all_merged_bugs {
323 my ($bug_num,$location) = @_;
325 my @data = (lockreadbug(@_));
326 if (not @data or not defined $data[0]) {
327 return ($locks,undef);
330 if (not length $data[0]->{mergedwith}) {
331 return ($locks,@data);
335 filelock("$config{spool_dir}/lock/merge");
337 @data = (lockreadbug(@_));
338 if (not @data or not defined $data[0]) {
339 unfilelock(); #for merge lock above
341 return ($locks,undef);
344 my @bugs = split / /, $data[0]->{mergedwith};
345 for my $bug (@bugs) {
347 if ($bug ne $bug_num) {
348 $newdata = lockreadbug($bug,$location);
349 if (not defined $newdata) {
354 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
355 return ($locks,undef);
360 # perform a sanity check to make sure that the merged bugs are
361 # all merged with eachother
362 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
363 if ($newdata->{mergedwith} ne $expectmerge) {
367 die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
370 return ($locks,@data);
374 my @v1fieldorder = qw(originator date subject msgid package
375 keywords done forwarded mergedwith severity);
379 my $content = makestatus($status,$version)
380 my $content = makestatus($status);
382 Creates the content for a status file based on the $status hashref
385 Really only useful for writebug
387 Currently defaults to version 2 (non-encoded rfc1522 names) but will
388 eventually default to version 3. If you care, you should specify a
394 my ($data,$version) = @_;
395 $version = 2 unless defined $version;
399 my %newdata = %$data;
400 for my $field (qw(found fixed)) {
401 if (exists $newdata{$field}) {
402 $newdata{"${field}_date"} =
403 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
407 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
408 $newdata{$field} = join ' ', @{$newdata{$field}||[]};
412 for my $field (@rfc1522_fields) {
413 $newdata{$field} = encode_rfc1522($newdata{$field});
418 for my $field (@v1fieldorder) {
419 if (exists $newdata{$field} and defined $newdata{$field}) {
420 $contents .= "$newdata{$field}\n";
425 } elsif ($version == 2 or $version == 3) {
426 # Version 2 or 3. Add a file format version number for the sake of
427 # further extensibility in the future.
428 $contents .= "Format-Version: $version\n";
429 for my $field (keys %fields) {
430 if (exists $newdata{$field} and defined $newdata{$field}
431 and $newdata{$field} ne '') {
432 # Output field names in proper case, e.g. 'Merged-With'.
433 my $properfield = $fields{$field};
434 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
435 $contents .= "$properfield: $newdata{$field}\n";
445 writebug($bug_num,$status,$location,$minversion,$disablebughook)
447 Writes the bug status and summary files out.
449 Skips writting out a status file if minversion is 2
451 Does not call bughook if disablebughook is true.
456 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
459 my %outputs = (1 => 'status', 2 => 'summary');
460 for my $version (keys %outputs) {
461 next if defined $minversion and $version < $minversion;
462 my $status = getbugcomponent($ref, $outputs{$version}, $location);
463 die "can't find location for $ref" unless defined $status;
464 open(S,"> $status.new") || die "opening $status.new: $!";
465 print(S makestatus($data, $version)) ||
466 die "writing $status.new: $!";
467 close(S) || die "closing $status.new: $!";
473 rename("$status.new",$status) || die "installing new $status: $!";
476 # $disablebughook is a bit of a hack to let format migration scripts use
477 # this function rather than having to duplicate it themselves.
478 &bughook($change,$ref,$data) unless $disablebughook;
481 =head2 unlockwritebug
483 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
485 Writes a bug, then calls unfilelock; see writebug for what these
497 The following functions are exported with the :versions tag
499 =head2 addfoundversions
501 addfoundversions($status,$package,$version,$isbinary);
508 sub addfoundversions {
512 my $isbinary = shift;
513 return unless defined $version;
514 undef $package if $package =~ m[(?:\s|/)];
515 my $source = $package;
517 if (defined $package and $isbinary) {
518 my @srcinfo = binarytosource($package, $version, undef);
520 # We know the source package(s). Use a fully-qualified version.
521 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
524 # Otherwise, an unqualified version will have to do.
528 # Strip off various kinds of brain-damage.
530 $version =~ s/ *\(.*\)//;
531 $version =~ s/ +[A-Za-z].*//;
533 foreach my $ver (split /[,\s]+/, $version) {
534 my $sver = defined($source) ? "$source/$ver" : '';
535 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
536 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
538 @{$data->{fixed_versions}} =
539 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
543 =head2 removefoundversions
545 removefoundversions($data,$package,$versiontoremove)
547 Removes found versions from $data
549 If a version is fully qualified (contains /) only versions matching
550 exactly are removed. Otherwise, all versions matching the version
553 Currently $package and $isbinary are entirely ignored, but accepted
554 for backwards compatibilty.
558 sub removefoundversions {
562 my $isbinary = shift;
563 return unless defined $version;
565 foreach my $ver (split /[,\s]+/, $version) {
567 # fully qualified version
568 @{$data->{found_versions}} =
570 @{$data->{found_versions}};
573 # non qualified version; delete all matchers
574 @{$data->{found_versions}} =
575 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
576 @{$data->{found_versions}};
582 sub addfixedversions {
586 my $isbinary = shift;
587 return unless defined $version;
588 undef $package if defined $package and $package =~ m[(?:\s|/)];
589 my $source = $package;
591 if (defined $package and $isbinary) {
592 my @srcinfo = binarytosource($package, $version, undef);
594 # We know the source package(s). Use a fully-qualified version.
595 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
598 # Otherwise, an unqualified version will have to do.
602 # Strip off various kinds of brain-damage.
604 $version =~ s/ *\(.*\)//;
605 $version =~ s/ +[A-Za-z].*//;
607 foreach my $ver (split /[,\s]+/, $version) {
608 my $sver = defined($source) ? "$source/$ver" : '';
609 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
610 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
612 @{$data->{found_versions}} =
613 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
617 sub removefixedversions {
621 my $isbinary = shift;
622 return unless defined $version;
624 foreach my $ver (split /[,\s]+/, $version) {
626 # fully qualified version
627 @{$data->{fixed_versions}} =
629 @{$data->{fixed_versions}};
632 # non qualified version; delete all matchers
633 @{$data->{fixed_versions}} =
634 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
635 @{$data->{fixed_versions}};
646 Split a package string from the status file into a list of package names.
652 return unless defined $pkgs;
653 return map lc, split /[ \t?,()]+/, $pkgs;
657 =head2 bug_archiveable
659 bug_archiveable(bug => $bug_num);
665 =item bug -- bug number (required)
667 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
669 =item version -- Debbugs::Version information (optional)
671 =item days_until -- return days until the bug can be archived
675 Returns 1 if the bug can be archived
676 Returns 0 if the bug cannot be archived
678 If days_until is true, returns the number of days until the bug can be
679 archived, -1 if it cannot be archived. 0 means that the bug can be
680 archived the next time the archiver runs.
682 Returns undef on failure.
686 # This will eventually need to be fixed before we start using mod_perl
687 our $version_cache = {};
689 my %param = validate_with(params => \@_,
690 spec => {bug => {type => SCALAR,
693 status => {type => HASHREF,
696 days_until => {type => BOOLEAN,
699 ignore_time => {type => BOOLEAN,
704 # This is what we return if the bug cannot be archived.
705 my $cannot_archive = $param{days_until}?-1:0;
706 # read the status information
707 my $status = $param{status};
708 if (not exists $param{status} or not defined $status) {
709 $status = read_bug(bug=>$param{bug});
710 if (not defined $status) {
711 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
715 # Bugs can be archived if they are
717 if (not defined $status->{done} or not length $status->{done}) {
718 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
719 return $cannot_archive
721 # Check to make sure that the bug has none of the unremovable tags set
722 if (@{$config{removal_unremovable_tags}}) {
723 for my $tag (split ' ', ($status->{tags}||'')) {
724 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
725 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
726 return $cannot_archive;
731 # If we just are checking if the bug can be archived, we'll not even bother
732 # checking the versioning information if the bug has been -done for less than 28 days.
733 my $log_file = getbugcomponent($param{bug},'log');
734 if (not defined $log_file) {
735 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
736 return $cannot_archive;
738 my $max_log_age = max(map {$config{remove_age} - -M $_}
739 $log_file, map {my $log = getbugcomponent($_,'log');
740 defined $log ? ($log) : ();
742 split / /, $status->{mergedwith}
744 if (not $param{days_until} and not $param{ignore_time}
747 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
748 return $cannot_archive;
750 # At this point, we have to get the versioning information for this bug.
751 # We examine the set of distribution tags. If a bug has no distribution
752 # tags set, we assume a default set, otherwise we use the tags the bug
755 # In cases where we are assuming a default set, if the severity
756 # is strong, we use the strong severity default; otherwise, we
757 # use the normal default.
759 # There must be fixed_versions for us to look at the versioning
761 my $min_fixed_time = time;
762 my $min_archive_days = 0;
763 if (@{$status->{fixed_versions}}) {
765 @dist_tags{@{$config{removal_distribution_tags}}} =
766 (1) x @{$config{removal_distribution_tags}};
768 for my $tag (split ' ', ($status->{tags}||'')) {
769 next unless exists $config{distribution_aliases}{$tag};
770 next unless $dist_tags{$config{distribution_aliases}{$tag}};
771 $dists{$config{distribution_aliases}{$tag}} = 1;
773 if (not keys %dists) {
774 if (isstrongseverity($status->{severity})) {
775 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
776 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
779 @dists{@{$config{removal_default_distribution_tags}}} =
780 (1) x @{$config{removal_default_distribution_tags}};
784 my @sourceversions = get_versions(package => $status->{package},
785 dist => [keys %dists],
788 @source_versions{@sourceversions} = (1) x @sourceversions;
789 # If the bug has not been fixed in the versions actually
790 # distributed, then it cannot be archived.
791 if ('found' eq max_buggy(bug => $param{bug},
792 sourceversions => [keys %source_versions],
793 found => $status->{found_versions},
794 fixed => $status->{fixed_versions},
795 version_cache => $version_cache,
796 package => $status->{package},
798 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
799 return $cannot_archive;
801 # Since the bug has at least been fixed in the architectures
802 # that matters, we check to see how long it has been fixed.
804 # If $param{ignore_time}, then we should ignore time.
805 if ($param{ignore_time}) {
806 return $param{days_until}?0:1;
809 # To do this, we order the times from most recent to oldest;
810 # when we come to the first found version, we stop.
811 # If we run out of versions, we only report the time of the
813 my %time_versions = get_versions(package => $status->{package},
814 dist => [keys %dists],
818 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
819 my $buggy = buggy(bug => $param{bug},
821 found => $status->{found_versions},
822 fixed => $status->{fixed_versions},
823 version_cache => $version_cache,
824 package => $status->{package},
826 last if $buggy eq 'found';
827 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
829 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
830 # if there are no versions in the archive at all, then
831 # we can archive if enough days have passed
834 # If $param{ignore_time}, then we should ignore time.
835 if ($param{ignore_time}) {
836 return $param{days_until}?0:1;
838 # 6. at least 28 days have passed since the last action has occured or the bug was closed
839 my $age = ceil($max_log_age);
840 if ($age > 0 or $min_archive_days > 0) {
841 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
842 return $param{days_until}?max($age,$min_archive_days):0;
845 return $param{days_until}?0:1;
850 =head2 get_bug_status
852 my $status = get_bug_status(bug => $nnn);
854 my $status = get_bug_status($bug_num)
860 =item bug -- scalar bug number
862 =item status -- optional hashref of bug status as returned by readbug
863 (can be passed to avoid rereading the bug information)
865 =item bug_index -- optional tied index of bug status infomration;
866 currently not correctly implemented.
868 =item version -- optional version(s) to check package status at
870 =item dist -- optional distribution(s) to check package status at
872 =item arch -- optional architecture(s) to check package status at
874 =item bugusertags -- optional hashref of bugusertags
876 =item sourceversion -- optional arrayref of source/version; overrides
877 dist, arch, and version. [The entries in this array must be in the
878 "source/version" format.] Eventually this can be used to for caching.
880 =item indicatesource -- if true, indicate which source packages this
881 bug could belong to. Defaults to false. [Note that eventually we will
882 properly allow bugs that only affect a source package, and this will
887 Note: Currently the version information is cached; this needs to be
888 changed before using this function in long lived programs.
896 my %param = validate_with(params => \@_,
897 spec => {bug => {type => SCALAR,
900 status => {type => HASHREF,
903 bug_index => {type => OBJECT,
906 version => {type => SCALAR|ARRAYREF,
909 dist => {type => SCALAR|ARRAYREF,
912 arch => {type => SCALAR|ARRAYREF,
915 bugusertags => {type => HASHREF,
918 sourceversions => {type => ARRAYREF,
921 indicatesource => {type => BOOLEAN,
928 if (defined $param{bug_index} and
929 exists $param{bug_index}{$param{bug}}) {
930 %status = %{ $param{bug_index}{$param{bug}} };
931 $status{pending} = $status{ status };
932 $status{id} = $param{bug};
935 if (defined $param{status}) {
936 %status = %{$param{status}};
939 my $location = getbuglocation($param{bug}, 'summary');
940 return {} if not defined $location or not length $location;
941 %status = %{ readbug( $param{bug}, $location ) };
943 $status{id} = $param{bug};
945 if (defined $param{bugusertags}{$param{bug}}) {
946 $status{keywords} = "" unless defined $status{keywords};
947 $status{keywords} .= " " unless $status{keywords} eq "";
948 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
950 $status{tags} = $status{keywords};
951 my %tags = map { $_ => 1 } split ' ', $status{tags};
953 $status{"package"} =~ s/\s*$//;
954 if ($param{indicatesource} and $status{package} ne '') {
955 $status{source} = join(', ',binarytosource($status{package}));
958 $status{source} = 'unknown';
960 $status{"package"} = 'unknown' if ($status{"package"} eq '');
961 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
963 $status{"pending"} = 'pending';
964 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
965 $status{"pending"} = 'pending-fixed' if ($tags{pending});
966 $status{"pending"} = 'fixed' if ($tags{fixed});
969 my $presence = bug_presence(status => \%status,
970 map{(exists $param{$_})?($_,$param{$_}):()}
971 qw(bug sourceversions arch dist version found fixed package)
973 if (defined $presence) {
974 if ($presence eq 'fixed') {
975 $status{pending} = 'done';
977 elsif ($presence eq 'absent') {
978 $status{pending} = 'absent';
986 my $precence = bug_presence(bug => nnn,
990 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
991 is found, absent, fixed, or no information is available in the
992 distribution (dist) and/or architecture (arch) specified.
999 =item bug -- scalar bug number
1001 =item status -- optional hashref of bug status as returned by readbug
1002 (can be passed to avoid rereading the bug information)
1004 =item bug_index -- optional tied index of bug status infomration;
1005 currently not correctly implemented.
1007 =item version -- optional version to check package status at
1009 =item dist -- optional distribution to check package status at
1011 =item arch -- optional architecture to check package status at
1013 =item sourceversion -- optional arrayref of source/version; overrides
1014 dist, arch, and version. [The entries in this array must be in the
1015 "source/version" format.] Eventually this can be used to for caching.
1022 my %param = validate_with(params => \@_,
1023 spec => {bug => {type => SCALAR,
1026 status => {type => HASHREF,
1029 version => {type => SCALAR|ARRAYREF,
1032 dist => {type => SCALAR|ARRAYREF,
1035 arch => {type => SCALAR|ARRAYREF,
1038 sourceversions => {type => ARRAYREF,
1044 if (defined $param{status}) {
1045 %status = %{$param{status}};
1048 my $location = getbuglocation($param{bug}, 'summary');
1049 return {} if not length $location;
1050 %status = %{ readbug( $param{bug}, $location ) };
1054 my $pseudo_desc = getpseudodesc();
1055 if (not exists $param{sourceversions}) {
1057 # pseudopackages do not have source versions by definition.
1058 if (exists $pseudo_desc->{$status{package}}) {
1061 elsif (defined $param{version}) {
1062 foreach my $arch (make_list($param{arch})) {
1063 for my $package (split /\s*,\s*/, $status{package}) {
1064 my @temp = makesourceversions($package,
1066 make_list($param{version})
1068 @sourceversions{@temp} = (1) x @temp;
1071 } elsif (defined $param{dist}) {
1072 my %affects_distribution_tags;
1073 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1074 (1) x @{$config{affects_distribution_tags}};
1075 my $some_distributions_disallowed = 0;
1076 my %allowed_distributions;
1077 for my $tag (split ' ', ($status->{tags}||'')) {
1078 if (exists $affects_distribution_tags{$tag}) {
1079 $some_distributions_disallowed = 1;
1080 $allowed_distributions{$tag} = 1;
1083 foreach my $arch (make_list($param{arch})) {
1084 for my $package (split /\s*,\s*/, $status{package}) {
1086 foreach my $dist (make_list($param{dist})) {
1087 # if some distributions are disallowed,
1088 # and this isn't an allowed
1089 # distribution, then we ignore this
1090 # distribution for the purposees of
1092 if ($some_distributions_disallowed and
1093 not exists $allowed_distributions{$tag}) {
1096 push @versions, getversions($package, $dist, $arch);
1098 next unless @versions;
1099 my @temp = makesourceversions($package,
1103 @sourceversions{@temp} = (1) x @temp;
1108 # TODO: This should probably be handled further out for efficiency and
1109 # for more ease of distinguishing between pkg= and src= queries.
1110 # DLA: src= queries should just pass arch=source, and they'll be happy.
1111 @sourceversions = keys %sourceversions;
1114 @sourceversions = @{$param{sourceversions}};
1116 my $maxbuggy = 'undef';
1117 if (@sourceversions) {
1118 $maxbuggy = max_buggy(bug => $param{bug},
1119 sourceversions => \@sourceversions,
1120 found => $status{found_versions},
1121 fixed => $status{fixed_versions},
1122 package => $status{package},
1123 version_cache => $version_cache,
1126 elsif (defined $param{dist} and
1127 not exists $pseudo_desc->{$status{package}}) {
1130 if (length($status{done}) and
1131 (not @sourceversions or not @{$status{fixed_versions}})) {
1146 =item bug -- scalar bug number
1148 =item sourceversion -- optional arrayref of source/version; overrides
1149 dist, arch, and version. [The entries in this array must be in the
1150 "source/version" format.] Eventually this can be used to for caching.
1154 Note: Currently the version information is cached; this needs to be
1155 changed before using this function in long lived programs.
1160 my %param = validate_with(params => \@_,
1161 spec => {bug => {type => SCALAR,
1164 sourceversions => {type => ARRAYREF,
1167 found => {type => ARRAYREF,
1170 fixed => {type => ARRAYREF,
1173 package => {type => SCALAR,
1175 version_cache => {type => HASHREF,
1180 # Resolve bugginess states (we might be looking at multiple
1181 # architectures, say). Found wins, then fixed, then absent.
1182 my $maxbuggy = 'absent';
1183 for my $package (split /\s*,\s*/, $param{package}) {
1184 for my $version (@{$param{sourceversions}}) {
1185 my $buggy = buggy(bug => $param{bug},
1186 version => $version,
1187 found => $param{found},
1188 fixed => $param{fixed},
1189 version_cache => $param{version_cache},
1190 package => $package,
1192 if ($buggy eq 'found') {
1194 } elsif ($buggy eq 'fixed') {
1195 $maxbuggy = 'fixed';
1212 Returns the output of Debbugs::Versions::buggy for a particular
1213 package, version and found/fixed set. Automatically turns found, fixed
1214 and version into source/version strings.
1216 Caching can be had by using the version_cache, but no attempt to check
1217 to see if the on disk information is more recent than the cache is
1218 made. [This will need to be fixed for long-lived processes.]
1223 my %param = validate_with(params => \@_,
1224 spec => {bug => {type => SCALAR,
1227 found => {type => ARRAYREF,
1230 fixed => {type => ARRAYREF,
1233 version_cache => {type => HASHREF,
1236 package => {type => SCALAR,
1238 version => {type => SCALAR,
1242 my @found = @{$param{found}};
1243 my @fixed = @{$param{fixed}};
1244 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1245 # We have non-source version versions
1246 @found = makesourceversions($param{package},undef,
1249 @fixed = makesourceversions($param{package},undef,
1253 if ($param{version} !~ m{/}) {
1254 my ($version) = makesourceversions($param{package},undef,
1257 $param{version} = $version if defined $version;
1259 # Figure out which source packages we need
1261 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1262 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1263 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1264 $param{version} =~ m{/};
1266 if (not defined $param{version_cache} or
1267 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1268 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1269 foreach my $source (keys %sources) {
1270 my $srchash = substr $source, 0, 1;
1271 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1272 if (not defined $version_fh) {
1273 # We only want to warn if it's a package which actually has a maintainer
1274 my $maints = getmaintainers();
1275 next if not exists $maints->{$source};
1276 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1279 $version->load($version_fh);
1281 if (defined $param{version_cache}) {
1282 $param{version_cache}{join(',',sort keys %sources)} = $version;
1286 $version = $param{version_cache}{join(',',sort keys %sources)};
1288 return $version->buggy($param{version},\@found,\@fixed);
1291 sub isstrongseverity {
1292 my $severity = shift;
1293 $severity = $config{default_severity} if
1294 not defined $severity or $severity eq '';
1295 return grep { $_ eq $severity } @{$config{strong_severities}};
1299 =head1 PRIVATE FUNCTIONS
1303 sub update_realtime {
1304 my ($file, %bugs) = @_;
1306 # update realtime index.db
1308 return () unless keys %bugs;
1309 my $idx_old = IO::File->new($file,'r')
1310 or die "Couldn't open ${file}: $!";
1311 my $idx_new = IO::File->new($file.'.new','w')
1312 or die "Couldn't open ${file}.new: $!";
1314 my $min_bug = min(keys %bugs);
1318 while($line = <$idx_old>) {
1319 @line = split /\s/, $line;
1320 # Two cases; replacing existing line or adding new line
1321 if (exists $bugs{$line[1]}) {
1322 my $new = $bugs{$line[1]};
1323 delete $bugs{$line[1]};
1324 $min_bug = min(keys %bugs);
1325 if ($new eq "NOCHANGE") {
1326 print {$idx_new} $line;
1327 $changed_bugs{$line[1]} = $line;
1328 } elsif ($new eq "REMOVE") {
1329 $changed_bugs{$line[1]} = $line;
1331 print {$idx_new} $new;
1332 $changed_bugs{$line[1]} = $line;
1336 while ($line[1] > $min_bug) {
1337 print {$idx_new} $bugs{$min_bug};
1338 delete $bugs{$min_bug};
1339 last unless keys %bugs;
1340 $min_bug = min(keys %bugs);
1342 print {$idx_new} $line;
1344 last unless keys %bugs;
1346 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1348 print {$idx_new} <$idx_old>;
1353 rename("$file.new", $file);
1355 return %changed_bugs;
1358 sub bughook_archive {
1360 &filelock("$config{spool_dir}/debbugs.trace.lock");
1361 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1362 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1363 map{($_,'REMOVE')} @refs);
1364 update_realtime("$config{spool_dir}/index.archive.realtime",
1370 my ( $type, %bugs_temp ) = @_;
1371 &filelock("$config{spool_dir}/debbugs.trace.lock");
1374 for my $bug (keys %bugs_temp) {
1375 my $data = $bugs_temp{$bug};
1376 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1378 my $whendone = "open";
1379 my $severity = $config{default_severity};
1380 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1381 $pkglist =~ s/^,+//;
1382 $pkglist =~ s/,+$//;
1383 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1384 $whendone = "done" if defined $data->{done} and length $data->{done};
1385 $severity = $data->{severity} if length $data->{severity};
1387 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1388 $pkglist, $bug, $data->{date}, $whendone,
1389 $data->{originator}, $severity, $data->{keywords};
1392 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);