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
35 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
36 use base qw(Exporter);
38 use Params::Validate qw(validate_with :types);
39 use Debbugs::Common qw(:util :lock :quit :misc);
40 use Debbugs::Config qw(:config);
41 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
42 use Debbugs::Packages qw(makesourceversions getversions get_versions binarytosource);
43 use Debbugs::Versions;
44 use Debbugs::Versions::Dpkg;
47 use List::Util qw(min max);
52 $DEBUG = 0 unless defined $DEBUG;
55 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
56 qw(isstrongseverity bug_presence),
58 read => [qw(readbug read_bug lockreadbug lockreadbugmerge)],
59 write => [qw(writebug makestatus unlockwritebug)],
60 versions => [qw(addfoundversions addfixedversions),
61 qw(removefoundversions removefixedversions)
63 hook => [qw(bughook bughook_archive)],
66 Exporter::export_ok_tags(qw(status read write versions hook));
67 $EXPORT_TAGS{all} = [@EXPORT_OK];
73 readbug($bug_num,$location)
76 Reads a summary file from the archive given a bug number and a bug
77 location. Valid locations are those understood by L</getbugcomponent>
82 my %fields = (originator => 'submitter',
85 msgid => 'message-id',
86 'package' => 'package',
89 forwarded => 'forwarded-to',
90 mergedwith => 'merged-with',
91 severity => 'severity',
93 found_versions => 'found-in',
94 found_date => 'found-date',
95 fixed_versions => 'fixed-in',
96 fixed_date => 'fixed-date',
98 blockedby => 'blocked-by',
99 unarchived => 'unarchived',
102 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
103 my @rfc1522_fields = qw(originator subject done forwarded owner);
106 return read_bug(bug => $_[0],
107 (@_ > 1)?(location => $_[1]):()
113 read_bug(bug => $bug_num,
114 location => 'archive',
116 read_bug(summary => 'path/to/bugnum.summary');
119 A more complete function than readbug; it enables you to pass a full
120 path to the summary file instead of the bug number and/or location.
126 =item bug -- the bug number
128 =item location -- optional location which is passed to getbugcomponent
130 =item summary -- complete path to the .summary file which will be read
134 One of C<bug> or C<summary> must be passed. This function will return
135 undef on failure, and will die if improper arguments are passed.
143 my %param = validate_with(params => \@_,
144 spec => {bug => {type => SCALAR,
148 # negative bugnumbers
151 location => {type => SCALAR|UNDEF,
154 summary => {type => SCALAR,
159 die "One of bug or summary must be passed to read_bug"
160 if not exists $param{bug} and not exists $param{summary};
164 if (not defined $param{summary}) {
166 ($lref,$location) = @param{qw(bug location)};
167 if (not defined $location) {
168 $location = getbuglocation($lref,'summary');
169 return undef if not defined $location;
171 $status = getbugcomponent($lref, 'summary', $location);
172 $log = getbugcomponent($lref, 'log' , $location);
173 return undef unless defined $status;
176 $status = $param{summary};
178 $log =~ s/\.summary$/.log/;
179 ($location) = $status =~ m/(db-h|db|archive)/;
181 my $status_fh = new IO::File $status, 'r' or
182 warn "Unable to open $status for reading: $!" and return undef;
189 while (<$status_fh>) {
192 $version = $1 if /^Format-Version: ([0-9]+)/i;
195 # Version 3 is the latest format version currently supported.
197 warn "Unsupported status version '$version'";
201 my %namemap = reverse %fields;
202 for my $line (@lines) {
203 if ($line =~ /(\S+?): (.*)/) {
204 my ($name, $value) = (lc $1, $2);
205 $data{$namemap{$name}} = $value if exists $namemap{$name};
208 for my $field (keys %fields) {
209 $data{$field} = '' unless exists $data{$field};
212 $data{severity} = $config{default_severity} if $data{severity} eq '';
213 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
214 $data{$field} = [split ' ', $data{$field}];
216 for my $field (qw(found fixed)) {
217 # create the found/fixed hashes which indicate when a
218 # particular version was marked found or marked fixed.
219 @{$data{$field}}{@{$data{"${field}_versions"}}} =
220 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
221 @{$data{"${field}_date"}});
225 for my $field (@rfc1522_fields) {
226 $data{$field} = decode_rfc1522($data{$field});
229 # Add log last modified time
230 $data{log_modified} = (stat($log))[9];
231 $data{location} = $location;
232 $data{bug_num} = $param{bug};
239 lockreadbug($bug_num,$location)
241 Performs a filelock, then reads the bug; the bug is unlocked if the
242 return is undefined, otherwise, you need to call unfilelock or
245 See readbug above for information on what this returns
250 my ($lref, $location) = @_;
251 &filelock("lock/$lref");
252 my $data = read_bug(bug => $lref, location => $location);
253 &unfilelock unless defined $data;
257 =head2 lockreadbugmerge
259 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
261 Performs a filelock, then reads the bug. If the bug is merged, locks
262 the merge lock. Returns a list of the number of locks and the bug
267 sub lockreadbugmerge {
268 my ($bug_num,$location) = @_;
269 my $data = lockreadbug(@_);
270 if (not defined $data) {
273 if (not length $data->{mergedwith}) {
277 filelock('lock/merge');
278 $data = lockreadbug(@_);
279 if (not defined $data) {
287 my @v1fieldorder = qw(originator date subject msgid package
288 keywords done forwarded mergedwith severity);
292 my $content = makestatus($status,$version)
293 my $content = makestatus($status);
295 Creates the content for a status file based on the $status hashref
298 Really only useful for writebug
300 Currently defaults to version 2 (non-encoded rfc1522 names) but will
301 eventually default to version 3. If you care, you should specify a
307 my ($data,$version) = @_;
308 $version = 2 unless defined $version;
312 my %newdata = %$data;
313 for my $field (qw(found fixed)) {
314 if (exists $newdata{$field}) {
315 $newdata{"${field}_date"} =
316 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
320 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
321 $newdata{$field} = join ' ', @{$newdata{$field}||[]};
325 for my $field (@rfc1522_fields) {
326 $newdata{$field} = encode_rfc1522($newdata{$field});
331 for my $field (@v1fieldorder) {
332 if (exists $newdata{$field} and defined $newdata{$field}) {
333 $contents .= "$newdata{$field}\n";
338 } elsif ($version == 2 or $version == 3) {
339 # Version 2 or 3. Add a file format version number for the sake of
340 # further extensibility in the future.
341 $contents .= "Format-Version: $version\n";
342 for my $field (keys %fields) {
343 if (exists $newdata{$field} and defined $newdata{$field}
344 and $newdata{$field} ne '') {
345 # Output field names in proper case, e.g. 'Merged-With'.
346 my $properfield = $fields{$field};
347 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
348 $contents .= "$properfield: $newdata{$field}\n";
358 writebug($bug_num,$status,$location,$minversion,$disablebughook)
360 Writes the bug status and summary files out.
362 Skips writting out a status file if minversion is 2
364 Does not call bughook if disablebughook is true.
369 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
372 my %outputs = (1 => 'status', 2 => 'summary');
373 for my $version (keys %outputs) {
374 next if defined $minversion and $version < $minversion;
375 my $status = getbugcomponent($ref, $outputs{$version}, $location);
376 die "can't find location for $ref" unless defined $status;
377 open(S,"> $status.new") || die "opening $status.new: $!";
378 print(S makestatus($data, $version)) ||
379 die "writing $status.new: $!";
380 close(S) || die "closing $status.new: $!";
386 rename("$status.new",$status) || die "installing new $status: $!";
389 # $disablebughook is a bit of a hack to let format migration scripts use
390 # this function rather than having to duplicate it themselves.
391 &bughook($change,$ref,$data) unless $disablebughook;
394 =head2 unlockwritebug
396 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
398 Writes a bug, then calls unfilelock; see writebug for what these
410 The following functions are exported with the :versions tag
412 =head2 addfoundversions
414 addfoundversions($status,$package,$version,$isbinary);
421 sub addfoundversions {
425 my $isbinary = shift;
426 return unless defined $version;
427 undef $package if $package =~ m[(?:\s|/)];
428 my $source = $package;
430 if (defined $package and $isbinary) {
431 my @srcinfo = binarytosource($package, $version, undef);
433 # We know the source package(s). Use a fully-qualified version.
434 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
437 # Otherwise, an unqualified version will have to do.
441 # Strip off various kinds of brain-damage.
443 $version =~ s/ *\(.*\)//;
444 $version =~ s/ +[A-Za-z].*//;
446 foreach my $ver (split /[,\s]+/, $version) {
447 my $sver = defined($source) ? "$source/$ver" : '';
448 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
449 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
451 @{$data->{fixed_versions}} =
452 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
456 =head2 removefoundversions
458 removefoundversions($data,$package,$versiontoremove)
460 Removes found versions from $data
462 If a version is fully qualified (contains /) only versions matching
463 exactly are removed. Otherwise, all versions matching the version
466 Currently $package and $isbinary are entirely ignored, but accepted
467 for backwards compatibilty.
471 sub removefoundversions {
475 my $isbinary = shift;
476 return unless defined $version;
478 foreach my $ver (split /[,\s]+/, $version) {
480 # fully qualified version
481 @{$data->{found_versions}} =
483 @{$data->{found_versions}};
486 # non qualified version; delete all matchers
487 @{$data->{found_versions}} =
488 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
489 @{$data->{found_versions}};
495 sub addfixedversions {
499 my $isbinary = shift;
500 return unless defined $version;
501 undef $package if defined $package and $package =~ m[(?:\s|/)];
502 my $source = $package;
504 if (defined $package and $isbinary) {
505 my @srcinfo = binarytosource($package, $version, undef);
507 # We know the source package(s). Use a fully-qualified version.
508 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
511 # Otherwise, an unqualified version will have to do.
515 # Strip off various kinds of brain-damage.
517 $version =~ s/ *\(.*\)//;
518 $version =~ s/ +[A-Za-z].*//;
520 foreach my $ver (split /[,\s]+/, $version) {
521 my $sver = defined($source) ? "$source/$ver" : '';
522 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
523 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
525 @{$data->{found_versions}} =
526 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
530 sub removefixedversions {
534 my $isbinary = shift;
535 return unless defined $version;
537 foreach my $ver (split /[,\s]+/, $version) {
539 # fully qualified version
540 @{$data->{fixed_versions}} =
542 @{$data->{fixed_versions}};
545 # non qualified version; delete all matchers
546 @{$data->{fixed_versions}} =
547 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
548 @{$data->{fixed_versions}};
559 Split a package string from the status file into a list of package names.
565 return unless defined $pkgs;
566 return map lc, split /[ \t?,()]+/, $pkgs;
570 =head2 bug_archiveable
572 bug_archiveable(bug => $bug_num);
578 =item bug -- bug number (required)
580 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
582 =item version -- Debbugs::Version information (optional)
584 =item days_until -- return days until the bug can be archived
588 Returns 1 if the bug can be archived
589 Returns 0 if the bug cannot be archived
591 If days_until is true, returns the number of days until the bug can be
592 archived, -1 if it cannot be archived. 0 means that the bug can be
593 archived the next time the archiver runs.
595 Returns undef on failure.
599 # This will eventually need to be fixed before we start using mod_perl
600 our $version_cache = {};
602 my %param = validate_with(params => \@_,
603 spec => {bug => {type => SCALAR,
606 status => {type => HASHREF,
609 days_until => {type => BOOLEAN,
612 ignore_time => {type => BOOLEAN,
617 # This is what we return if the bug cannot be archived.
618 my $cannot_archive = $param{days_until}?-1:0;
619 # read the status information
620 my $status = $param{status};
621 if (not exists $param{status} or not defined $status) {
622 $status = read_bug(bug=>$param{bug});
623 if (not defined $status) {
624 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
628 # Bugs can be archived if they are
630 if (not defined $status->{done} or not length $status->{done}) {
631 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
632 return $cannot_archive
634 # If we just are checking if the bug can be archived, we'll not even bother
635 # checking the versioning information if the bug has been -done for less than 28 days.
636 my $log_file = getbugcomponent($param{bug},'log');
637 if (not defined $log_file) {
638 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
639 return $cannot_archive;
641 my $max_log_age = max(map {$config{remove_age} - -M $_}
642 $log_file, map {my $log = getbugcomponent($_,'log');
643 defined $log ? ($log) : ();
645 split / /, $status->{mergedwith}
647 if (not $param{days_until} and not $param{ignore_time}
650 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
651 return $cannot_archive;
653 # At this point, we have to get the versioning information for this bug.
654 # We examine the set of distribution tags. If a bug has no distribution
655 # tags set, we assume a default set, otherwise we use the tags the bug
658 # In cases where we are assuming a default set, if the severity
659 # is strong, we use the strong severity default; otherwise, we
660 # use the normal default.
662 # There must be fixed_versions for us to look at the versioning
664 my $min_fixed_time = time;
665 my $min_archive_days = 0;
666 if (@{$status->{fixed_versions}}) {
668 @dist_tags{@{$config{removal_distribution_tags}}} =
669 (1) x @{$config{removal_distribution_tags}};
671 for my $tag (split ' ', ($status->{tags}||'')) {
672 next unless exists $config{distribution_aliases}{$tag};
673 next unless $dist_tags{$config{distribution_aliases}{$tag}};
674 $dists{$config{distribution_aliases}{$tag}} = 1;
676 if (not keys %dists) {
677 if (isstrongseverity($status->{severity})) {
678 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
679 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
682 @dists{@{$config{removal_default_distribution_tags}}} =
683 (1) x @{$config{removal_default_distribution_tags}};
687 my @sourceversions = get_versions(package => $status->{package},
688 dist => [keys %dists],
691 @source_versions{@sourceversions} = (1) x @sourceversions;
692 # If the bug has not been fixed in the versions actually
693 # distributed, then it cannot be archived.
694 if ('found' eq max_buggy(bug => $param{bug},
695 sourceversions => [keys %source_versions],
696 found => $status->{found_versions},
697 fixed => $status->{fixed_versions},
698 version_cache => $version_cache,
699 package => $status->{package},
701 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
702 return $cannot_archive;
704 # Since the bug has at least been fixed in the architectures
705 # that matters, we check to see how long it has been fixed.
707 # If $param{ignore_time}, then we should ignore time.
708 if ($param{ignore_time}) {
709 return $param{days_until}?0:1;
712 # To do this, we order the times from most recent to oldest;
713 # when we come to the first found version, we stop.
714 # If we run out of versions, we only report the time of the
716 my %time_versions = get_versions(package => $status->{package},
717 dist => [keys %dists],
721 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
722 my $buggy = buggy(bug => $param{bug},
724 found => $status->{found_versions},
725 fixed => $status->{fixed_versions},
726 version_cache => $version_cache,
727 package => $status->{package},
729 last if $buggy eq 'found';
730 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
732 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
733 # if there are no versions in the archive at all, then
734 # we can archive if enough days have passed
737 # If $param{ignore_time}, then we should ignore time.
738 if ($param{ignore_time}) {
739 return $param{days_until}?0:1;
741 # 6. at least 28 days have passed since the last action has occured or the bug was closed
742 my $age = ceil($max_log_age);
743 if ($age > 0 or $min_archive_days > 0) {
744 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
745 return $param{days_until}?max($age,$min_archive_days):0;
748 return $param{days_until}?0:1;
753 =head2 get_bug_status
755 my $status = get_bug_status(bug => $nnn);
757 my $status = get_bug_status($bug_num)
763 =item bug -- scalar bug number
765 =item status -- optional hashref of bug status as returned by readbug
766 (can be passed to avoid rereading the bug information)
768 =item bug_index -- optional tied index of bug status infomration;
769 currently not correctly implemented.
771 =item version -- optional version(s) to check package status at
773 =item dist -- optional distribution(s) to check package status at
775 =item arch -- optional architecture(s) to check package status at
777 =item bugusertags -- optional hashref of bugusertags
779 =item sourceversion -- optional arrayref of source/version; overrides
780 dist, arch, and version. [The entries in this array must be in the
781 "source/version" format.] Eventually this can be used to for caching.
783 =item indicatesource -- if true, indicate which source packages this
784 bug could belong to. Defaults to false. [Note that eventually we will
785 properly allow bugs that only affect a source package, and this will
790 Note: Currently the version information is cached; this needs to be
791 changed before using this function in long lived programs.
799 my %param = validate_with(params => \@_,
800 spec => {bug => {type => SCALAR,
803 status => {type => HASHREF,
806 bug_index => {type => OBJECT,
809 version => {type => SCALAR|ARRAYREF,
812 dist => {type => SCALAR|ARRAYREF,
815 arch => {type => SCALAR|ARRAYREF,
818 bugusertags => {type => HASHREF,
821 sourceversions => {type => ARRAYREF,
824 indicatesource => {type => BOOLEAN,
831 if (defined $param{bug_index} and
832 exists $param{bug_index}{$param{bug}}) {
833 %status = %{ $param{bug_index}{$param{bug}} };
834 $status{pending} = $status{ status };
835 $status{id} = $param{bug};
838 if (defined $param{status}) {
839 %status = %{$param{status}};
842 my $location = getbuglocation($param{bug}, 'summary');
843 return {} if not defined $location or not length $location;
844 %status = %{ readbug( $param{bug}, $location ) };
846 $status{id} = $param{bug};
848 if (defined $param{bugusertags}{$param{bug}}) {
849 $status{keywords} = "" unless defined $status{keywords};
850 $status{keywords} .= " " unless $status{keywords} eq "";
851 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
853 $status{tags} = $status{keywords};
854 my %tags = map { $_ => 1 } split ' ', $status{tags};
856 $status{"package"} =~ s/\s*$//;
857 if ($param{indicatesource} and $status{package} ne '') {
858 $status{source} = join(', ',binarytosource($status{package}));
861 $status{source} = 'unknown';
863 $status{"package"} = 'unknown' if ($status{"package"} eq '');
864 $status{"severity"} = 'normal' if ($status{"severity"} eq '');
866 $status{"pending"} = 'pending';
867 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
868 $status{"pending"} = 'pending-fixed' if ($tags{pending});
869 $status{"pending"} = 'fixed' if ($tags{fixed});
872 my $presence = bug_presence(map{(exists $param{$_})?($_,$param{$_}):()}
873 qw(bug sourceversions arch dist version found fixed package)
875 if (defined $presence) {
876 if ($presence eq 'fixed') {
877 $status{pending} = 'done';
879 elsif ($presence eq 'absent') {
880 $status{pending} = 'absent';
888 my $precence = bug_presence(bug => nnn,
892 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
893 is found, absent, fixed, or no information is available in the
894 distribution (dist) and/or architecture (arch) specified.
901 =item bug -- scalar bug number
903 =item status -- optional hashref of bug status as returned by readbug
904 (can be passed to avoid rereading the bug information)
906 =item bug_index -- optional tied index of bug status infomration;
907 currently not correctly implemented.
909 =item version -- optional version to check package status at
911 =item dist -- optional distribution to check package status at
913 =item arch -- optional architecture to check package status at
915 =item sourceversion -- optional arrayref of source/version; overrides
916 dist, arch, and version. [The entries in this array must be in the
917 "source/version" format.] Eventually this can be used to for caching.
924 my %param = validate_with(params => \@_,
925 spec => {bug => {type => SCALAR,
928 status => {type => HASHREF,
931 version => {type => SCALAR|ARRAYREF,
934 dist => {type => SCALAR|ARRAYREF,
937 arch => {type => SCALAR|ARRAYREF,
940 sourceversions => {type => ARRAYREF,
946 if (defined $param{status}) {
947 %status = %{$param{status}};
950 my $location = getbuglocation($param{bug}, 'summary');
951 return {} if not length $location;
952 %status = %{ readbug( $param{bug}, $location ) };
956 my $pseudo_desc = getpseudodesc();
957 if (not exists $param{sourceversions}) {
959 # pseudopackages do not have source versions by definition.
960 if (exists $pseudo_desc->{$status{package}}) {
963 elsif (defined $param{version}) {
964 foreach my $arch (make_list($param{arch})) {
965 for my $package (split /\s*,\s*/, $status{package}) {
966 my @temp = makesourceversions($package,
968 make_list($param{version})
970 @sourceversions{@temp} = (1) x @temp;
973 } elsif (defined $param{dist}) {
974 foreach my $arch (make_list($param{arch})) {
976 for my $package (split /\s*,\s*/, $status{package}) {
977 foreach my $dist (make_list($param{dist})) {
978 push @versions, getversions($package, $dist, $arch);
980 my @temp = makesourceversions($package,
984 @sourceversions{@temp} = (1) x @temp;
989 # TODO: This should probably be handled further out for efficiency and
990 # for more ease of distinguishing between pkg= and src= queries.
991 # DLA: src= queries should just pass arch=source, and they'll be happy.
992 @sourceversions = keys %sourceversions;
995 @sourceversions = @{$param{sourceversions}};
997 my $maxbuggy = 'undef';
998 if (@sourceversions) {
999 $maxbuggy = max_buggy(bug => $param{bug},
1000 sourceversions => \@sourceversions,
1001 found => $status{found_versions},
1002 fixed => $status{fixed_versions},
1003 package => $status{package},
1004 version_cache => $version_cache,
1007 elsif (defined $param{dist} and
1008 not exists $pseudo_desc->{$status{package}}) {
1011 if (length($status{done}) and
1012 (not @sourceversions or not @{$status{fixed_versions}})) {
1027 =item bug -- scalar bug number
1029 =item sourceversion -- optional arrayref of source/version; overrides
1030 dist, arch, and version. [The entries in this array must be in the
1031 "source/version" format.] Eventually this can be used to for caching.
1035 Note: Currently the version information is cached; this needs to be
1036 changed before using this function in long lived programs.
1041 my %param = validate_with(params => \@_,
1042 spec => {bug => {type => SCALAR,
1045 sourceversions => {type => ARRAYREF,
1048 found => {type => ARRAYREF,
1051 fixed => {type => ARRAYREF,
1054 package => {type => SCALAR,
1056 version_cache => {type => HASHREF,
1061 # Resolve bugginess states (we might be looking at multiple
1062 # architectures, say). Found wins, then fixed, then absent.
1063 my $maxbuggy = 'absent';
1064 for my $package (split /\s*,\s*/, $param{package}) {
1065 for my $version (@{$param{sourceversions}}) {
1066 my $buggy = buggy(bug => $param{bug},
1067 version => $version,
1068 found => $param{found},
1069 fixed => $param{fixed},
1070 version_cache => $param{version_cache},
1071 package => $package,
1073 if ($buggy eq 'found') {
1075 } elsif ($buggy eq 'fixed') {
1076 $maxbuggy = 'fixed';
1093 Returns the output of Debbugs::Versions::buggy for a particular
1094 package, version and found/fixed set. Automatically turns found, fixed
1095 and version into source/version strings.
1097 Caching can be had by using the version_cache, but no attempt to check
1098 to see if the on disk information is more recent than the cache is
1099 made. [This will need to be fixed for long-lived processes.]
1104 my %param = validate_with(params => \@_,
1105 spec => {bug => {type => SCALAR,
1108 found => {type => ARRAYREF,
1111 fixed => {type => ARRAYREF,
1114 version_cache => {type => HASHREF,
1117 package => {type => SCALAR,
1119 version => {type => SCALAR,
1123 my @found = @{$param{found}};
1124 my @fixed = @{$param{fixed}};
1125 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1126 # We have non-source version versions
1127 @found = makesourceversions($param{package},undef,
1130 @fixed = makesourceversions($param{package},undef,
1134 if ($param{version} !~ m{/}) {
1135 my ($version) = makesourceversions($param{package},undef,
1138 $param{version} = $version if defined $version;
1140 # Figure out which source packages we need
1142 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1143 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1144 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1145 $param{version} =~ m{/};
1147 if (not defined $param{version_cache} or
1148 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1149 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1150 foreach my $source (keys %sources) {
1151 my $srchash = substr $source, 0, 1;
1152 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1153 if (not defined $version_fh) {
1154 # We only want to warn if it's a package which actually has a maintainer
1155 my $maints = getmaintainers();
1156 next if not exists $maints->{$source};
1157 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1160 $version->load($version_fh);
1162 if (defined $param{version_cache}) {
1163 $param{version_cache}{join(',',sort keys %sources)} = $version;
1167 $version = $param{version_cache}{join(',',sort keys %sources)};
1169 return $version->buggy($param{version},\@found,\@fixed);
1172 sub isstrongseverity {
1173 my $severity = shift;
1174 $severity = $config{default_severity} if
1175 not defined $severity or $severity eq '';
1176 return grep { $_ eq $severity } @{$config{strong_severities}};
1180 =head1 PRIVATE FUNCTIONS
1184 sub update_realtime {
1185 my ($file, %bugs) = @_;
1187 # update realtime index.db
1189 return () unless keys %bugs;
1190 my $idx_old = IO::File->new($file,'r')
1191 or die "Couldn't open ${file}: $!";
1192 my $idx_new = IO::File->new($file.'.new','w')
1193 or die "Couldn't open ${file}.new: $!";
1195 my $min_bug = min(keys %bugs);
1199 while($line = <$idx_old>) {
1200 @line = split /\s/, $line;
1201 # Two cases; replacing existing line or adding new line
1202 if (exists $bugs{$line[1]}) {
1203 my $new = $bugs{$line[1]};
1204 delete $bugs{$line[1]};
1205 $min_bug = min(keys %bugs);
1206 if ($new eq "NOCHANGE") {
1207 print {$idx_new} $line;
1208 $changed_bugs{$line[1]} = $line;
1209 } elsif ($new eq "REMOVE") {
1210 $changed_bugs{$line[1]} = $line;
1212 print {$idx_new} $new;
1213 $changed_bugs{$line[1]} = $line;
1217 while ($line[1] > $min_bug) {
1218 print {$idx_new} $bugs{$min_bug};
1219 delete $bugs{$min_bug};
1220 last unless keys %bugs;
1221 $min_bug = min(keys %bugs);
1223 print {$idx_new} $line;
1225 last unless keys %bugs;
1227 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1229 print {$idx_new} <$idx_old>;
1234 rename("$file.new", $file);
1236 return %changed_bugs;
1239 sub bughook_archive {
1241 &filelock("debbugs.trace.lock");
1242 &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1243 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1244 map{($_,'REMOVE')} @refs);
1245 update_realtime("$config{spool_dir}/index.archive.realtime",
1251 my ( $type, %bugs_temp ) = @_;
1252 &filelock("debbugs.trace.lock");
1255 for my $bug (keys %bugs_temp) {
1256 my $data = $bugs_temp{$bug};
1257 &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1259 my $whendone = "open";
1260 my $severity = $config{default_severity};
1261 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1262 $pkglist =~ s/^,+//;
1263 $pkglist =~ s/,+$//;
1264 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1265 $whendone = "done" if defined $data->{done} and length $data->{done};
1266 $severity = $data->{severity} if length $data->{severity};
1268 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1269 $pkglist, $bug, $data->{date}, $whendone,
1270 $data->{originator}, $severity, $data->{keywords};
1273 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);