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 :utf8);
41 use Debbugs::Config qw(:config);
42 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
43 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
44 use Debbugs::Versions;
45 use Debbugs::Versions::Dpkg;
47 use File::Copy qw(copy);
48 use Encode qw(decode encode is_utf8);
50 use Storable qw(dclone);
51 use List::Util qw(min max);
57 $DEBUG = 0 unless defined $DEBUG;
60 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
61 qw(isstrongseverity bug_presence split_status_fields),
63 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
64 qw(lock_read_all_merged_bugs),
66 write => [qw(writebug makestatus unlockwritebug)],
68 versions => [qw(addfoundversions addfixedversions),
69 qw(removefoundversions removefixedversions)
71 hook => [qw(bughook bughook_archive)],
72 fields => [qw(%fields)],
75 Exporter::export_ok_tags(keys %EXPORT_TAGS);
76 $EXPORT_TAGS{all} = [@EXPORT_OK];
82 readbug($bug_num,$location)
85 Reads a summary file from the archive given a bug number and a bug
86 location. Valid locations are those understood by L</getbugcomponent>
90 # these probably shouldn't be imported by most people, but
91 # Debbugs::Control needs them, so they're now exportable
92 our %fields = (originator => 'submitter',
95 msgid => 'message-id',
96 'package' => 'package',
99 forwarded => 'forwarded-to',
100 mergedwith => 'merged-with',
101 severity => 'severity',
103 found_versions => 'found-in',
104 found_date => 'found-date',
105 fixed_versions => 'fixed-in',
106 fixed_date => 'fixed-date',
108 blockedby => 'blocked-by',
109 unarchived => 'unarchived',
110 summary => 'summary',
111 affects => 'affects',
115 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
116 my @rfc1522_fields = qw(originator subject done forwarded owner);
119 return read_bug(bug => $_[0],
120 (@_ > 1)?(location => $_[1]):()
126 read_bug(bug => $bug_num,
127 location => 'archive',
129 read_bug(summary => 'path/to/bugnum.summary');
132 A more complete function than readbug; it enables you to pass a full
133 path to the summary file instead of the bug number and/or location.
139 =item bug -- the bug number
141 =item location -- optional location which is passed to getbugcomponent
143 =item summary -- complete path to the .summary file which will be read
145 =item lock -- whether to obtain a lock for the bug to prevent
146 something modifying it while the bug has been read. You B<must> call
147 C<unfilelock();> if something not undef is returned from read_bug.
149 =item locks -- hashref of already obtained locks; incremented as new
150 locks are needed, and decremented as locks are released on particular
155 One of C<bug> or C<summary> must be passed. This function will return
156 undef on failure, and will die if improper arguments are passed.
164 my %param = validate_with(params => \@_,
165 spec => {bug => {type => SCALAR,
169 # negative bugnumbers
172 location => {type => SCALAR|UNDEF,
175 summary => {type => SCALAR,
178 lock => {type => BOOLEAN,
181 locks => {type => HASHREF,
186 die "One of bug or summary must be passed to read_bug"
187 if not exists $param{bug} and not exists $param{summary};
191 if (not defined $param{summary}) {
193 ($lref,$location) = @param{qw(bug location)};
194 if (not defined $location) {
195 $location = getbuglocation($lref,'summary');
196 return undef if not defined $location;
198 $status = getbugcomponent($lref, 'summary', $location);
199 $log = getbugcomponent($lref, 'log' , $location);
200 return undef unless defined $status;
201 return undef if not -e $status;
204 $status = $param{summary};
206 $log =~ s/\.summary$/.log/;
207 ($location) = $status =~ m/(db-h|db|archive)/;
210 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
212 my $status_fh = IO::File->new($status, 'r');
213 if (not defined $status_fh) {
214 warn "Unable to open $status for reading: $!";
216 unfilelock(exists $param{locks}?$param{locks}:());
220 binmode($status_fh,':encoding(UTF-8)');
227 while (<$status_fh>) {
230 $version = $1 if /^Format-Version: ([0-9]+)/i;
233 # Version 3 is the latest format version currently supported.
235 warn "Unsupported status version '$version'";
237 unfilelock(exists $param{locks}?$param{locks}:());
242 my %namemap = reverse %fields;
243 for my $line (@lines) {
244 if ($line =~ /(\S+?): (.*)/) {
245 my ($name, $value) = (lc $1, $2);
246 # this is a bit of a hack; we should never, ever have \r
247 # or \n in the fields of status. Kill them off here.
248 # [Eventually, this should be superfluous.]
249 $value =~ s/[\r\n]//g;
250 $data{$namemap{$name}} = $value if exists $namemap{$name};
253 for my $field (keys %fields) {
254 $data{$field} = '' unless exists $data{$field};
257 for my $field (@rfc1522_fields) {
258 $data{$field} = decode_rfc1522($data{$field});
261 $data{severity} = $config{default_severity} if $data{severity} eq '';
262 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
263 $data{$field} = [split ' ', $data{$field}];
265 for my $field (qw(found fixed)) {
266 # create the found/fixed hashes which indicate when a
267 # particular version was marked found or marked fixed.
268 @{$data{$field}}{@{$data{"${field}_versions"}}} =
269 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
270 @{$data{"${field}_date"}});
273 my $status_modified = (stat($status))[9];
274 # Add log last modified time
275 $data{log_modified} = (stat($log))[9];
276 $data{last_modified} = max($status_modified,$data{log_modified});
277 $data{location} = $location;
278 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
279 $data{bug_num} = $param{bug};
284 =head2 split_status_fields
286 my @data = split_status_fields(@data);
288 Splits splittable status fields (like package, tags, blocks,
289 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
290 passed @data intact using dclone.
292 In scalar context, returns only the first element of @data.
296 our $ditch_empty = sub{
298 my $splitter = shift @t;
299 return grep {length $_} map {split $splitter} @t;
302 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
304 (package => \&splitpackages,
305 affects => \&splitpackages,
306 blocks => $ditch_empty_space,
307 blockedby => $ditch_empty_space,
308 # this isn't strictly correct, but we'll split both of them for
309 # the time being until we ditch all use of keywords everywhere
311 keywords => $ditch_empty_space,
312 tags => $ditch_empty_space,
313 found_versions => $ditch_empty_space,
314 fixed_versions => $ditch_empty_space,
315 mergedwith => $ditch_empty_space,
318 sub split_status_fields {
319 my @data = @{dclone(\@_)};
320 for my $data (@data) {
321 next if not defined $data;
322 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
323 not (ref($data) and ref($data) eq 'HASH');
324 for my $field (keys %{$data}) {
325 next unless defined $data->{$field};
326 if (exists $split_fields{$field}) {
327 next if ref($data->{$field});
329 if (ref($split_fields{$field}) eq 'CODE') {
330 @elements = &{$split_fields{$field}}($data->{$field});
332 elsif (not ref($split_fields{$field}) or
333 UNIVERSAL::isa($split_fields{$field},'Regex')
335 @elements = split $split_fields{$field}, $data->{$field};
337 $data->{$field} = \@elements;
341 return wantarray?@data:$data[0];
344 =head2 join_status_fields
346 my @data = join_status_fields(@data);
348 Handles joining the splitable status fields. (Basically, the inverse
349 of split_status_fields.
351 Primarily called from makestatus, but may be useful for other
352 functions after calling split_status_fields (or for legacy functions
353 if we transition to split fields by default).
357 sub join_status_fields {
364 found_versions => ' ',
365 fixed_versions => ' ',
370 my @data = @{dclone(\@_)};
371 for my $data (@data) {
372 next if not defined $data;
373 croak "Passed an element which is not a hashref to split_status_field: ".
375 if ref($data) ne 'HASH';
376 for my $field (keys %{$data}) {
377 next unless defined $data->{$field};
378 next unless ref($data->{$field}) eq 'ARRAY';
379 next unless exists $join_fields{$field};
380 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
383 return wantarray?@data:$data[0];
389 lockreadbug($bug_num,$location)
391 Performs a filelock, then reads the bug; the bug is unlocked if the
392 return is undefined, otherwise, you need to call unfilelock or
395 See readbug above for information on what this returns
400 my ($lref, $location) = @_;
401 return read_bug(bug => $lref, location => $location, lock => 1);
404 =head2 lockreadbugmerge
406 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
408 Performs a filelock, then reads the bug. If the bug is merged, locks
409 the merge lock. Returns a list of the number of locks and the bug
414 sub lockreadbugmerge {
415 my ($bug_num,$location) = @_;
416 my $data = lockreadbug(@_);
417 if (not defined $data) {
420 if (not length $data->{mergedwith}) {
424 filelock("$config{spool_dir}/lock/merge");
425 $data = lockreadbug(@_);
426 if (not defined $data) {
433 =head2 lock_read_all_merged_bugs
435 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
437 Performs a filelock, then reads the bug passed. If the bug is merged,
438 locks the merge lock, then reads and locks all of the other merged
439 bugs. Returns a list of the number of locks and the bug data for all
442 Will also return undef if any of the merged bugs failed to be read,
443 even if all of the others were read properly.
447 sub lock_read_all_merged_bugs {
448 my %param = validate_with(params => \@_,
449 spec => {bug => {type => SCALAR,
452 location => {type => SCALAR,
455 locks => {type => HASHREF,
461 my @data = read_bug(bug => $param{bug},
463 exists $param{location} ? (location => $param{location}):(),
464 exists $param{locks} ? (locks => $param{locks}):(),
466 if (not @data or not defined $data[0]) {
470 if (not length $data[0]->{mergedwith}) {
471 return ($locks,@data);
473 unfilelock(exists $param{locks}?$param{locks}:());
475 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
477 @data = read_bug(bug => $param{bug},
479 exists $param{location} ? (location => $param{location}):(),
480 exists $param{locks} ? (locks => $param{locks}):(),
482 if (not @data or not defined $data[0]) {
483 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
488 my @bugs = split / /, $data[0]->{mergedwith};
489 push @bugs, $param{bug};
490 for my $bug (@bugs) {
492 if ($bug != $param{bug}) {
494 read_bug(bug => $bug,
496 exists $param{location} ? (location => $param{location}):(),
497 exists $param{locks} ? (locks => $param{locks}):(),
499 if (not defined $newdata) {
501 unfilelock(exists $param{locks}?$param{locks}:());
504 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
509 # perform a sanity check to make sure that the merged bugs
510 # are all merged with eachother
511 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } @bugs);
512 if ($newdata->{mergedwith} ne $expectmerge) {
514 unfilelock(exists $param{locks}?$param{locks}:());
516 die "Bug $param{bug} differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
520 return ($locks,@data);
525 my $new_bug_num = new_bug(copy => $data->{bug_num});
527 Creates a new bug and returns the new bug number upon success.
535 validate_with(params => \@_,
536 spec => {copy => {type => SCALAR,
542 filelock("nextnumber.lock");
543 my $nn_fh = IO::File->new("nextnumber",'r') or
544 die "Unable to open nextnuber for reading: $!";
547 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
549 overwritefile("nextnumber",
552 my $nn_hash = get_hashname($nn);
554 my $c_hash = get_hashname($param{copy});
555 for my $file (qw(log status summary report)) {
556 copy("db-h/$c_hash/$param{copy}.$file",
557 "db-h/$nn_hash/${nn}.$file")
561 for my $file (qw(log status summary report)) {
562 overwritefile("db-h/$nn_hash/${nn}.$file",
567 # this probably needs to be munged to do something more elegant
568 # &bughook('new', $clone, $data);
575 my @v1fieldorder = qw(originator date subject msgid package
576 keywords done forwarded mergedwith severity);
580 my $content = makestatus($status,$version)
581 my $content = makestatus($status);
583 Creates the content for a status file based on the $status hashref
586 Really only useful for writebug
588 Currently defaults to version 2 (non-encoded rfc1522 names) but will
589 eventually default to version 3. If you care, you should specify a
595 my ($data,$version) = @_;
596 $version = 3 unless defined $version;
600 my %newdata = %$data;
601 for my $field (qw(found fixed)) {
602 if (exists $newdata{$field}) {
603 $newdata{"${field}_date"} =
604 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
607 %newdata = %{join_status_fields(\%newdata)};
609 %newdata = encode_utf8_structure(%newdata);
612 for my $field (@rfc1522_fields) {
613 $newdata{$field} = encode_rfc1522($newdata{$field});
617 # this is a bit of a hack; we should never, ever have \r or \n in
618 # the fields of status. Kill them off here. [Eventually, this
619 # should be superfluous.]
620 for my $field (keys %newdata) {
621 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
625 for my $field (@v1fieldorder) {
626 if (exists $newdata{$field} and defined $newdata{$field}) {
627 $contents .= "$newdata{$field}\n";
632 } elsif ($version == 2 or $version == 3) {
633 # Version 2 or 3. Add a file format version number for the sake of
634 # further extensibility in the future.
635 $contents .= "Format-Version: $version\n";
636 for my $field (keys %fields) {
637 if (exists $newdata{$field} and defined $newdata{$field}
638 and $newdata{$field} ne '') {
639 # Output field names in proper case, e.g. 'Merged-With'.
640 my $properfield = $fields{$field};
641 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
642 my $data = $newdata{$field};
643 $contents .= "$properfield: $data\n";
652 writebug($bug_num,$status,$location,$minversion,$disablebughook)
654 Writes the bug status and summary files out.
656 Skips writting out a status file if minversion is 2
658 Does not call bughook if disablebughook is true.
663 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
666 my %outputs = (1 => 'status', 3 => 'summary');
667 for my $version (keys %outputs) {
668 next if defined $minversion and $version < $minversion;
669 my $status = getbugcomponent($ref, $outputs{$version}, $location);
670 die "can't find location for $ref" unless defined $status;
673 open $sfh,">","$status.new" or
674 die "opening $status.new: $!";
677 open $sfh,">","$status.new" or
678 die "opening $status.new: $!";
680 print {$sfh} makestatus($data, $version) or
681 die "writing $status.new: $!";
682 close($sfh) or die "closing $status.new: $!";
688 rename("$status.new",$status) || die "installing new $status: $!";
691 # $disablebughook is a bit of a hack to let format migration scripts use
692 # this function rather than having to duplicate it themselves.
693 &bughook($change,$ref,$data) unless $disablebughook;
696 =head2 unlockwritebug
698 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
700 Writes a bug, then calls unfilelock; see writebug for what these
712 The following functions are exported with the :versions tag
714 =head2 addfoundversions
716 addfoundversions($status,$package,$version,$isbinary);
718 All use of this should be phased out in favor of Debbugs::Control::fixed/found
723 sub addfoundversions {
727 my $isbinary = shift;
728 return unless defined $version;
729 undef $package if $package =~ m[(?:\s|/)];
730 my $source = $package;
731 if ($package =~ s/^src://) {
736 if (defined $package and $isbinary) {
737 my @srcinfo = binary_to_source(binary => $package,
738 version => $version);
740 # We know the source package(s). Use a fully-qualified version.
741 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
744 # Otherwise, an unqualified version will have to do.
748 # Strip off various kinds of brain-damage.
750 $version =~ s/ *\(.*\)//;
751 $version =~ s/ +[A-Za-z].*//;
753 foreach my $ver (split /[,\s]+/, $version) {
754 my $sver = defined($source) ? "$source/$ver" : '';
755 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
756 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
758 @{$data->{fixed_versions}} =
759 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
763 =head2 removefoundversions
765 removefoundversions($data,$package,$versiontoremove)
767 Removes found versions from $data
769 If a version is fully qualified (contains /) only versions matching
770 exactly are removed. Otherwise, all versions matching the version
773 Currently $package and $isbinary are entirely ignored, but accepted
774 for backwards compatibilty.
778 sub removefoundversions {
782 my $isbinary = shift;
783 return unless defined $version;
785 foreach my $ver (split /[,\s]+/, $version) {
787 # fully qualified version
788 @{$data->{found_versions}} =
790 @{$data->{found_versions}};
793 # non qualified version; delete all matchers
794 @{$data->{found_versions}} =
795 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
796 @{$data->{found_versions}};
802 sub addfixedversions {
806 my $isbinary = shift;
807 return unless defined $version;
808 undef $package if defined $package and $package =~ m[(?:\s|/)];
809 my $source = $package;
811 if (defined $package and $isbinary) {
812 my @srcinfo = binary_to_source(binary => $package,
813 version => $version);
815 # We know the source package(s). Use a fully-qualified version.
816 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
819 # Otherwise, an unqualified version will have to do.
823 # Strip off various kinds of brain-damage.
825 $version =~ s/ *\(.*\)//;
826 $version =~ s/ +[A-Za-z].*//;
828 foreach my $ver (split /[,\s]+/, $version) {
829 my $sver = defined($source) ? "$source/$ver" : '';
830 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
831 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
833 @{$data->{found_versions}} =
834 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
838 sub removefixedversions {
842 my $isbinary = shift;
843 return unless defined $version;
845 foreach my $ver (split /[,\s]+/, $version) {
847 # fully qualified version
848 @{$data->{fixed_versions}} =
850 @{$data->{fixed_versions}};
853 # non qualified version; delete all matchers
854 @{$data->{fixed_versions}} =
855 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
856 @{$data->{fixed_versions}};
867 Split a package string from the status file into a list of package names.
873 return unless defined $pkgs;
874 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
878 =head2 bug_archiveable
880 bug_archiveable(bug => $bug_num);
886 =item bug -- bug number (required)
888 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
890 =item version -- Debbugs::Version information (optional)
892 =item days_until -- return days until the bug can be archived
896 Returns 1 if the bug can be archived
897 Returns 0 if the bug cannot be archived
899 If days_until is true, returns the number of days until the bug can be
900 archived, -1 if it cannot be archived. 0 means that the bug can be
901 archived the next time the archiver runs.
903 Returns undef on failure.
907 # This will eventually need to be fixed before we start using mod_perl
908 our $version_cache = {};
910 my %param = validate_with(params => \@_,
911 spec => {bug => {type => SCALAR,
914 status => {type => HASHREF,
917 days_until => {type => BOOLEAN,
920 ignore_time => {type => BOOLEAN,
925 # This is what we return if the bug cannot be archived.
926 my $cannot_archive = $param{days_until}?-1:0;
927 # read the status information
928 my $status = $param{status};
929 if (not exists $param{status} or not defined $status) {
930 $status = read_bug(bug=>$param{bug});
931 if (not defined $status) {
932 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
936 # Bugs can be archived if they are
938 if (not defined $status->{done} or not length $status->{done}) {
939 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
940 return $cannot_archive
942 # Check to make sure that the bug has none of the unremovable tags set
943 if (@{$config{removal_unremovable_tags}}) {
944 for my $tag (split ' ', ($status->{keywords}||'')) {
945 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
946 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
947 return $cannot_archive;
952 # If we just are checking if the bug can be archived, we'll not even bother
953 # checking the versioning information if the bug has been -done for less than 28 days.
954 my $log_file = getbugcomponent($param{bug},'log');
955 if (not defined $log_file) {
956 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
957 return $cannot_archive;
959 my $max_log_age = max(map {$config{remove_age} - -M $_}
960 $log_file, map {my $log = getbugcomponent($_,'log');
961 defined $log ? ($log) : ();
963 split / /, $status->{mergedwith}
965 if (not $param{days_until} and not $param{ignore_time}
968 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
969 return $cannot_archive;
971 # At this point, we have to get the versioning information for this bug.
972 # We examine the set of distribution tags. If a bug has no distribution
973 # tags set, we assume a default set, otherwise we use the tags the bug
976 # In cases where we are assuming a default set, if the severity
977 # is strong, we use the strong severity default; otherwise, we
978 # use the normal default.
980 # There must be fixed_versions for us to look at the versioning
982 my $min_fixed_time = time;
983 my $min_archive_days = 0;
984 if (@{$status->{fixed_versions}}) {
986 @dist_tags{@{$config{removal_distribution_tags}}} =
987 (1) x @{$config{removal_distribution_tags}};
989 for my $tag (split ' ', ($status->{keywords}||'')) {
990 next unless exists $config{distribution_aliases}{$tag};
991 next unless $dist_tags{$config{distribution_aliases}{$tag}};
992 $dists{$config{distribution_aliases}{$tag}} = 1;
994 if (not keys %dists) {
995 if (isstrongseverity($status->{severity})) {
996 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
997 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1000 @dists{@{$config{removal_default_distribution_tags}}} =
1001 (1) x @{$config{removal_default_distribution_tags}};
1004 my %source_versions;
1005 my @sourceversions = get_versions(package => $status->{package},
1006 dist => [keys %dists],
1009 @source_versions{@sourceversions} = (1) x @sourceversions;
1010 # If the bug has not been fixed in the versions actually
1011 # distributed, then it cannot be archived.
1012 if ('found' eq max_buggy(bug => $param{bug},
1013 sourceversions => [keys %source_versions],
1014 found => $status->{found_versions},
1015 fixed => $status->{fixed_versions},
1016 version_cache => $version_cache,
1017 package => $status->{package},
1019 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1020 return $cannot_archive;
1022 # Since the bug has at least been fixed in the architectures
1023 # that matters, we check to see how long it has been fixed.
1025 # If $param{ignore_time}, then we should ignore time.
1026 if ($param{ignore_time}) {
1027 return $param{days_until}?0:1;
1030 # To do this, we order the times from most recent to oldest;
1031 # when we come to the first found version, we stop.
1032 # If we run out of versions, we only report the time of the
1034 my %time_versions = get_versions(package => $status->{package},
1035 dist => [keys %dists],
1039 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1040 my $buggy = buggy(bug => $param{bug},
1041 version => $version,
1042 found => $status->{found_versions},
1043 fixed => $status->{fixed_versions},
1044 version_cache => $version_cache,
1045 package => $status->{package},
1047 last if $buggy eq 'found';
1048 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1050 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1051 # if there are no versions in the archive at all, then
1052 # we can archive if enough days have passed
1055 # If $param{ignore_time}, then we should ignore time.
1056 if ($param{ignore_time}) {
1057 return $param{days_until}?0:1;
1059 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1060 my $age = ceil($max_log_age);
1061 if ($age > 0 or $min_archive_days > 0) {
1062 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1063 return $param{days_until}?max($age,$min_archive_days):0;
1066 return $param{days_until}?0:1;
1071 =head2 get_bug_status
1073 my $status = get_bug_status(bug => $nnn);
1075 my $status = get_bug_status($bug_num)
1081 =item bug -- scalar bug number
1083 =item status -- optional hashref of bug status as returned by readbug
1084 (can be passed to avoid rereading the bug information)
1086 =item bug_index -- optional tied index of bug status infomration;
1087 currently not correctly implemented.
1089 =item version -- optional version(s) to check package status at
1091 =item dist -- optional distribution(s) to check package status at
1093 =item arch -- optional architecture(s) to check package status at
1095 =item bugusertags -- optional hashref of bugusertags
1097 =item sourceversion -- optional arrayref of source/version; overrides
1098 dist, arch, and version. [The entries in this array must be in the
1099 "source/version" format.] Eventually this can be used to for caching.
1101 =item indicatesource -- if true, indicate which source packages this
1102 bug could belong to (or does belong to in the case of bugs assigned to
1103 a source package). Defaults to true.
1107 Note: Currently the version information is cached; this needs to be
1108 changed before using this function in long lived programs.
1112 sub get_bug_status {
1116 my %param = validate_with(params => \@_,
1117 spec => {bug => {type => SCALAR,
1120 status => {type => HASHREF,
1123 bug_index => {type => OBJECT,
1126 version => {type => SCALAR|ARRAYREF,
1129 dist => {type => SCALAR|ARRAYREF,
1132 arch => {type => SCALAR|ARRAYREF,
1135 bugusertags => {type => HASHREF,
1138 sourceversions => {type => ARRAYREF,
1141 indicatesource => {type => BOOLEAN,
1148 if (defined $param{bug_index} and
1149 exists $param{bug_index}{$param{bug}}) {
1150 %status = %{ $param{bug_index}{$param{bug}} };
1151 $status{pending} = $status{ status };
1152 $status{id} = $param{bug};
1155 if (defined $param{status}) {
1156 %status = %{$param{status}};
1159 my $location = getbuglocation($param{bug}, 'summary');
1160 return {} if not defined $location or not length $location;
1161 %status = %{ readbug( $param{bug}, $location ) };
1163 $status{id} = $param{bug};
1165 if (defined $param{bugusertags}{$param{bug}}) {
1166 $status{keywords} = "" unless defined $status{keywords};
1167 $status{keywords} .= " " unless $status{keywords} eq "";
1168 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1170 $status{tags} = $status{keywords};
1171 my %tags = map { $_ => 1 } split ' ', $status{tags};
1173 $status{package} = '' if not defined $status{package};
1174 $status{"package"} =~ s/\s*$//;
1176 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1180 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1181 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1183 $status{"pending"} = 'pending';
1184 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1185 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1186 $status{"pending"} = 'fixed' if ($tags{fixed});
1189 my $presence = bug_presence(status => \%status,
1190 map{(exists $param{$_})?($_,$param{$_}):()}
1191 qw(bug sourceversions arch dist version found fixed package)
1193 if (defined $presence) {
1194 if ($presence eq 'fixed') {
1195 $status{pending} = 'done';
1197 elsif ($presence eq 'absent') {
1198 $status{pending} = 'absent';
1206 my $precence = bug_presence(bug => nnn,
1210 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1211 is found, absent, fixed, or no information is available in the
1212 distribution (dist) and/or architecture (arch) specified.
1219 =item bug -- scalar bug number
1221 =item status -- optional hashref of bug status as returned by readbug
1222 (can be passed to avoid rereading the bug information)
1224 =item bug_index -- optional tied index of bug status infomration;
1225 currently not correctly implemented.
1227 =item version -- optional version to check package status at
1229 =item dist -- optional distribution to check package status at
1231 =item arch -- optional architecture to check package status at
1233 =item sourceversion -- optional arrayref of source/version; overrides
1234 dist, arch, and version. [The entries in this array must be in the
1235 "source/version" format.] Eventually this can be used to for caching.
1242 my %param = validate_with(params => \@_,
1243 spec => {bug => {type => SCALAR,
1246 status => {type => HASHREF,
1249 version => {type => SCALAR|ARRAYREF,
1252 dist => {type => SCALAR|ARRAYREF,
1255 arch => {type => SCALAR|ARRAYREF,
1258 sourceversions => {type => ARRAYREF,
1264 if (defined $param{status}) {
1265 %status = %{$param{status}};
1268 my $location = getbuglocation($param{bug}, 'summary');
1269 return {} if not length $location;
1270 %status = %{ readbug( $param{bug}, $location ) };
1274 my $pseudo_desc = getpseudodesc();
1275 if (not exists $param{sourceversions}) {
1277 # pseudopackages do not have source versions by definition.
1278 if (exists $pseudo_desc->{$status{package}}) {
1281 elsif (defined $param{version}) {
1282 foreach my $arch (make_list($param{arch})) {
1283 for my $package (split /\s*,\s*/, $status{package}) {
1284 my @temp = makesourceversions($package,
1286 make_list($param{version})
1288 @sourceversions{@temp} = (1) x @temp;
1291 } elsif (defined $param{dist}) {
1292 my %affects_distribution_tags;
1293 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1294 (1) x @{$config{affects_distribution_tags}};
1295 my $some_distributions_disallowed = 0;
1296 my %allowed_distributions;
1297 for my $tag (split ' ', ($status{keywords}||'')) {
1298 if (exists $config{distribution_aliases}{$tag} and
1299 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1300 $some_distributions_disallowed = 1;
1301 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1303 elsif (exists $affects_distribution_tags{$tag}) {
1304 $some_distributions_disallowed = 1;
1305 $allowed_distributions{$tag} = 1;
1308 my @archs = make_list(exists $param{arch}?$param{arch}:());
1309 GET_SOURCE_VERSIONS:
1310 foreach my $arch (@archs) {
1311 for my $package (split /\s*,\s*/, $status{package}) {
1314 if ($package =~ /^src:(.+)$/) {
1318 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1319 # if some distributions are disallowed,
1320 # and this isn't an allowed
1321 # distribution, then we ignore this
1322 # distribution for the purposees of
1324 if ($some_distributions_disallowed and
1325 not exists $allowed_distributions{$dist}) {
1328 push @versions, get_versions(package => $package,
1330 ($source?(arch => 'source'):
1331 (defined $arch?(arch => $arch):())),
1334 next unless @versions;
1335 my @temp = make_source_versions(package => $package,
1337 versions => \@versions,
1339 @sourceversions{@temp} = (1) x @temp;
1342 # this should really be split out into a subroutine,
1343 # but it'd touch so many things currently, that we fake
1344 # it; it's needed to properly handle bugs which are
1345 # erroneously assigned to the binary package, and we'll
1346 # probably have it go away eventually.
1347 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1349 goto GET_SOURCE_VERSIONS;
1353 # TODO: This should probably be handled further out for efficiency and
1354 # for more ease of distinguishing between pkg= and src= queries.
1355 # DLA: src= queries should just pass arch=source, and they'll be happy.
1356 @sourceversions = keys %sourceversions;
1359 @sourceversions = @{$param{sourceversions}};
1361 my $maxbuggy = 'undef';
1362 if (@sourceversions) {
1363 $maxbuggy = max_buggy(bug => $param{bug},
1364 sourceversions => \@sourceversions,
1365 found => $status{found_versions},
1366 fixed => $status{fixed_versions},
1367 package => $status{package},
1368 version_cache => $version_cache,
1371 elsif (defined $param{dist} and
1372 not exists $pseudo_desc->{$status{package}}) {
1375 if (length($status{done}) and
1376 (not @sourceversions or not @{$status{fixed_versions}})) {
1391 =item bug -- scalar bug number
1393 =item sourceversion -- optional arrayref of source/version; overrides
1394 dist, arch, and version. [The entries in this array must be in the
1395 "source/version" format.] Eventually this can be used to for caching.
1399 Note: Currently the version information is cached; this needs to be
1400 changed before using this function in long lived programs.
1405 my %param = validate_with(params => \@_,
1406 spec => {bug => {type => SCALAR,
1409 sourceversions => {type => ARRAYREF,
1412 found => {type => ARRAYREF,
1415 fixed => {type => ARRAYREF,
1418 package => {type => SCALAR,
1420 version_cache => {type => HASHREF,
1425 # Resolve bugginess states (we might be looking at multiple
1426 # architectures, say). Found wins, then fixed, then absent.
1427 my $maxbuggy = 'absent';
1428 for my $package (split /\s*,\s*/, $param{package}) {
1429 for my $version (@{$param{sourceversions}}) {
1430 my $buggy = buggy(bug => $param{bug},
1431 version => $version,
1432 found => $param{found},
1433 fixed => $param{fixed},
1434 version_cache => $param{version_cache},
1435 package => $package,
1437 if ($buggy eq 'found') {
1439 } elsif ($buggy eq 'fixed') {
1440 $maxbuggy = 'fixed';
1457 Returns the output of Debbugs::Versions::buggy for a particular
1458 package, version and found/fixed set. Automatically turns found, fixed
1459 and version into source/version strings.
1461 Caching can be had by using the version_cache, but no attempt to check
1462 to see if the on disk information is more recent than the cache is
1463 made. [This will need to be fixed for long-lived processes.]
1468 my %param = validate_with(params => \@_,
1469 spec => {bug => {type => SCALAR,
1472 found => {type => ARRAYREF,
1475 fixed => {type => ARRAYREF,
1478 version_cache => {type => HASHREF,
1481 package => {type => SCALAR,
1483 version => {type => SCALAR,
1487 my @found = @{$param{found}};
1488 my @fixed = @{$param{fixed}};
1489 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1490 # We have non-source version versions
1491 @found = makesourceversions($param{package},undef,
1494 @fixed = makesourceversions($param{package},undef,
1498 if ($param{version} !~ m{/}) {
1499 my ($version) = makesourceversions($param{package},undef,
1502 $param{version} = $version if defined $version;
1504 # Figure out which source packages we need
1506 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1507 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1508 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1509 $param{version} =~ m{/};
1511 if (not defined $param{version_cache} or
1512 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1513 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1514 foreach my $source (keys %sources) {
1515 my $srchash = substr $source, 0, 1;
1516 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1517 if (not defined $version_fh) {
1518 # We only want to warn if it's a package which actually has a maintainer
1519 my $maints = getmaintainers();
1520 next if not exists $maints->{$source};
1521 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1524 $version->load($version_fh);
1526 if (defined $param{version_cache}) {
1527 $param{version_cache}{join(',',sort keys %sources)} = $version;
1531 $version = $param{version_cache}{join(',',sort keys %sources)};
1533 return $version->buggy($param{version},\@found,\@fixed);
1536 sub isstrongseverity {
1537 my $severity = shift;
1538 $severity = $config{default_severity} if
1539 not defined $severity or $severity eq '';
1540 return grep { $_ eq $severity } @{$config{strong_severities}};
1544 =head1 PRIVATE FUNCTIONS
1548 sub update_realtime {
1549 my ($file, %bugs) = @_;
1551 # update realtime index.db
1553 return () unless keys %bugs;
1554 my $idx_old = IO::File->new($file,'r')
1555 or die "Couldn't open ${file}: $!";
1556 my $idx_new = IO::File->new($file.'.new','w')
1557 or die "Couldn't open ${file}.new: $!";
1559 my $min_bug = min(keys %bugs);
1563 while($line = <$idx_old>) {
1564 @line = split /\s/, $line;
1565 # Two cases; replacing existing line or adding new line
1566 if (exists $bugs{$line[1]}) {
1567 my $new = $bugs{$line[1]};
1568 delete $bugs{$line[1]};
1569 $min_bug = min(keys %bugs);
1570 if ($new eq "NOCHANGE") {
1571 print {$idx_new} $line;
1572 $changed_bugs{$line[1]} = $line;
1573 } elsif ($new eq "REMOVE") {
1574 $changed_bugs{$line[1]} = $line;
1576 print {$idx_new} $new;
1577 $changed_bugs{$line[1]} = $line;
1581 while ($line[1] > $min_bug) {
1582 print {$idx_new} $bugs{$min_bug};
1583 delete $bugs{$min_bug};
1584 last unless keys %bugs;
1585 $min_bug = min(keys %bugs);
1587 print {$idx_new} $line;
1589 last unless keys %bugs;
1591 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1593 print {$idx_new} <$idx_old>;
1598 rename("$file.new", $file);
1600 return %changed_bugs;
1603 sub bughook_archive {
1605 filelock("$config{spool_dir}/debbugs.trace.lock");
1606 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1607 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1608 map{($_,'REMOVE')} @refs);
1609 update_realtime("$config{spool_dir}/index.archive.realtime",
1615 my ( $type, %bugs_temp ) = @_;
1616 filelock("$config{spool_dir}/debbugs.trace.lock");
1619 for my $bug (keys %bugs_temp) {
1620 my $data = $bugs_temp{$bug};
1621 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1623 my $whendone = "open";
1624 my $severity = $config{default_severity};
1625 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1626 $pkglist =~ s/^,+//;
1627 $pkglist =~ s/,+$//;
1628 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1629 $whendone = "done" if defined $data->{done} and length $data->{done};
1630 $severity = $data->{severity} if length $data->{severity};
1632 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1633 $pkglist, $bug, $data->{date}, $whendone,
1634 $data->{originator}, $severity, $data->{keywords};
1637 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);