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}:());
226 while (<$status_fh>) {
229 $version = $1 if /^Format-Version: ([0-9]+)/i;
232 # Version 3 is the latest format version currently supported.
234 warn "Unsupported status version '$version'";
236 unfilelock(exists $param{locks}?$param{locks}:());
241 my %namemap = reverse %fields;
242 for my $field (keys %fields) {
243 $data{$field} = '' unless exists $data{$field};
246 for my $field (@rfc1522_fields) {
247 $data{$field} = decode_rfc1522($data{$field});
250 for my $line (@lines) {
251 my @encodings_to_try = qw(utf8 iso8859-1);
253 @encodings_to_try = qw(utf8);
255 for (@encodings_to_try) {
256 last if is_utf8($line);
259 $temp = decode("$_",$line,Encode::FB_CROAK);
261 if (not $@) { # only update the line if there are no errors.
266 if ($line =~ /(\S+?): (.*)/) {
267 my ($name, $value) = (lc $1, $2);
268 # this is a bit of a hack; we should never, ever have \r
269 # or \n in the fields of status. Kill them off here.
270 # [Eventually, this should be superfluous.]
271 $value =~ s/[\r\n]//g;
272 $data{$namemap{$name}} = $value if exists $namemap{$name};
275 $data{severity} = $config{default_severity} if $data{severity} eq '';
276 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
277 $data{$field} = [split ' ', $data{$field}];
279 for my $field (qw(found fixed)) {
280 # create the found/fixed hashes which indicate when a
281 # particular version was marked found or marked fixed.
282 @{$data{$field}}{@{$data{"${field}_versions"}}} =
283 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
284 @{$data{"${field}_date"}});
287 my $status_modified = (stat($status))[9];
288 # Add log last modified time
289 $data{log_modified} = (stat($log))[9];
290 $data{last_modified} = max($status_modified,$data{log_modified});
291 $data{location} = $location;
292 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
293 $data{bug_num} = $param{bug};
298 =head2 split_status_fields
300 my @data = split_status_fields(@data);
302 Splits splittable status fields (like package, tags, blocks,
303 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
304 passed @data intact using dclone.
306 In scalar context, returns only the first element of @data.
310 our $ditch_empty = sub{
312 my $splitter = shift @t;
313 return grep {length $_} map {split $splitter} @t;
316 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
318 (package => \&splitpackages,
319 affects => \&splitpackages,
320 blocks => $ditch_empty_space,
321 blockedby => $ditch_empty_space,
322 # this isn't strictly correct, but we'll split both of them for
323 # the time being until we ditch all use of keywords everywhere
325 keywords => $ditch_empty_space,
326 tags => $ditch_empty_space,
327 found_versions => $ditch_empty_space,
328 fixed_versions => $ditch_empty_space,
329 mergedwith => $ditch_empty_space,
332 sub split_status_fields {
333 my @data = @{dclone(\@_)};
334 for my $data (@data) {
335 next if not defined $data;
336 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
337 not (ref($data) and ref($data) eq 'HASH');
338 for my $field (keys %{$data}) {
339 next unless defined $data->{$field};
340 if (exists $split_fields{$field}) {
341 next if ref($data->{$field});
343 if (ref($split_fields{$field}) eq 'CODE') {
344 @elements = &{$split_fields{$field}}($data->{$field});
346 elsif (not ref($split_fields{$field}) or
347 UNIVERSAL::isa($split_fields{$field},'Regex')
349 @elements = split $split_fields{$field}, $data->{$field};
351 $data->{$field} = \@elements;
355 return wantarray?@data:$data[0];
358 =head2 join_status_fields
360 my @data = join_status_fields(@data);
362 Handles joining the splitable status fields. (Basically, the inverse
363 of split_status_fields.
365 Primarily called from makestatus, but may be useful for other
366 functions after calling split_status_fields (or for legacy functions
367 if we transition to split fields by default).
371 sub join_status_fields {
378 found_versions => ' ',
379 fixed_versions => ' ',
384 my @data = @{dclone(\@_)};
385 for my $data (@data) {
386 next if not defined $data;
387 croak "Passed an element which is not a hashref to split_status_field: ".
389 if ref($data) ne 'HASH';
390 for my $field (keys %{$data}) {
391 next unless defined $data->{$field};
392 next unless ref($data->{$field}) eq 'ARRAY';
393 next unless exists $join_fields{$field};
394 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
397 return wantarray?@data:$data[0];
403 lockreadbug($bug_num,$location)
405 Performs a filelock, then reads the bug; the bug is unlocked if the
406 return is undefined, otherwise, you need to call unfilelock or
409 See readbug above for information on what this returns
414 my ($lref, $location) = @_;
415 return read_bug(bug => $lref, location => $location, lock => 1);
418 =head2 lockreadbugmerge
420 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
422 Performs a filelock, then reads the bug. If the bug is merged, locks
423 the merge lock. Returns a list of the number of locks and the bug
428 sub lockreadbugmerge {
429 my ($bug_num,$location) = @_;
430 my $data = lockreadbug(@_);
431 if (not defined $data) {
434 if (not length $data->{mergedwith}) {
438 filelock("$config{spool_dir}/lock/merge");
439 $data = lockreadbug(@_);
440 if (not defined $data) {
447 =head2 lock_read_all_merged_bugs
449 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
451 Performs a filelock, then reads the bug passed. If the bug is merged,
452 locks the merge lock, then reads and locks all of the other merged
453 bugs. Returns a list of the number of locks and the bug data for all
456 Will also return undef if any of the merged bugs failed to be read,
457 even if all of the others were read properly.
461 sub lock_read_all_merged_bugs {
462 my %param = validate_with(params => \@_,
463 spec => {bug => {type => SCALAR,
466 location => {type => SCALAR,
469 locks => {type => HASHREF,
475 my @data = read_bug(bug => $param{bug},
477 exists $param{location} ? (location => $param{location}):(),
478 exists $param{locks} ? (locks => $param{locks}):(),
480 if (not @data or not defined $data[0]) {
484 if (not length $data[0]->{mergedwith}) {
485 return ($locks,@data);
487 unfilelock(exists $param{locks}?$param{locks}:());
489 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
491 @data = read_bug(bug => $param{bug},
493 exists $param{location} ? (location => $param{location}):(),
494 exists $param{locks} ? (locks => $param{locks}):(),
496 if (not @data or not defined $data[0]) {
497 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
502 my @bugs = split / /, $data[0]->{mergedwith};
503 push @bugs, $param{bug};
504 for my $bug (@bugs) {
506 if ($bug != $param{bug}) {
508 read_bug(bug => $bug,
510 exists $param{location} ? (location => $param{location}):(),
511 exists $param{locks} ? (locks => $param{locks}):(),
513 if (not defined $newdata) {
515 unfilelock(exists $param{locks}?$param{locks}:());
518 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
523 # perform a sanity check to make sure that the merged bugs
524 # are all merged with eachother
525 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } @bugs);
526 if ($newdata->{mergedwith} ne $expectmerge) {
528 unfilelock(exists $param{locks}?$param{locks}:());
530 die "Bug $param{bug} differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
534 return ($locks,@data);
539 my $new_bug_num = new_bug(copy => $data->{bug_num});
541 Creates a new bug and returns the new bug number upon success.
549 validate_with(params => \@_,
550 spec => {copy => {type => SCALAR,
556 filelock("nextnumber.lock");
557 my $nn_fh = IO::File->new("nextnumber",'r') or
558 die "Unable to open nextnuber for reading: $!";
561 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
563 overwritefile("nextnumber",
566 my $nn_hash = get_hashname($nn);
568 my $c_hash = get_hashname($param{copy});
569 for my $file (qw(log status summary report)) {
570 copy("db-h/$c_hash/$param{copy}.$file",
571 "db-h/$nn_hash/${nn}.$file")
575 for my $file (qw(log status summary report)) {
576 overwritefile("db-h/$nn_hash/${nn}.$file",
581 # this probably needs to be munged to do something more elegant
582 # &bughook('new', $clone, $data);
589 my @v1fieldorder = qw(originator date subject msgid package
590 keywords done forwarded mergedwith severity);
594 my $content = makestatus($status,$version)
595 my $content = makestatus($status);
597 Creates the content for a status file based on the $status hashref
600 Really only useful for writebug
602 Currently defaults to version 2 (non-encoded rfc1522 names) but will
603 eventually default to version 3. If you care, you should specify a
609 my ($data,$version) = @_;
610 $version = 3 unless defined $version;
614 my %newdata = %$data;
615 for my $field (qw(found fixed)) {
616 if (exists $newdata{$field}) {
617 $newdata{"${field}_date"} =
618 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
621 %newdata = %{join_status_fields(\%newdata)};
623 %newdata = encode_utf8_structure(%newdata);
626 for my $field (@rfc1522_fields) {
627 $newdata{$field} = encode_rfc1522($newdata{$field});
631 # this is a bit of a hack; we should never, ever have \r or \n in
632 # the fields of status. Kill them off here. [Eventually, this
633 # should be superfluous.]
634 for my $field (keys %newdata) {
635 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
639 for my $field (@v1fieldorder) {
640 if (exists $newdata{$field} and defined $newdata{$field}) {
641 $contents .= "$newdata{$field}\n";
646 } elsif ($version == 2 or $version == 3) {
647 # Version 2 or 3. Add a file format version number for the sake of
648 # further extensibility in the future.
649 $contents .= "Format-Version: $version\n";
650 for my $field (keys %fields) {
651 if (exists $newdata{$field} and defined $newdata{$field}
652 and $newdata{$field} ne '') {
653 # Output field names in proper case, e.g. 'Merged-With'.
654 my $properfield = $fields{$field};
655 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
656 my $data = $newdata{$field};
657 $contents .= "$properfield: $data\n";
666 writebug($bug_num,$status,$location,$minversion,$disablebughook)
668 Writes the bug status and summary files out.
670 Skips writting out a status file if minversion is 2
672 Does not call bughook if disablebughook is true.
677 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
680 my %outputs = (1 => 'status', 3 => 'summary');
681 for my $version (keys %outputs) {
682 next if defined $minversion and $version < $minversion;
683 my $status = getbugcomponent($ref, $outputs{$version}, $location);
684 die "can't find location for $ref" unless defined $status;
687 open $sfh,">","$status.new" or
688 die "opening $status.new: $!";
691 open $sfh,">","$status.new" or
692 die "opening $status.new: $!";
694 print {$sfh} makestatus($data, $version) or
695 die "writing $status.new: $!";
696 close($sfh) or die "closing $status.new: $!";
702 rename("$status.new",$status) || die "installing new $status: $!";
705 # $disablebughook is a bit of a hack to let format migration scripts use
706 # this function rather than having to duplicate it themselves.
707 &bughook($change,$ref,$data) unless $disablebughook;
710 =head2 unlockwritebug
712 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
714 Writes a bug, then calls unfilelock; see writebug for what these
726 The following functions are exported with the :versions tag
728 =head2 addfoundversions
730 addfoundversions($status,$package,$version,$isbinary);
732 All use of this should be phased out in favor of Debbugs::Control::fixed/found
737 sub addfoundversions {
741 my $isbinary = shift;
742 return unless defined $version;
743 undef $package if $package =~ m[(?:\s|/)];
744 my $source = $package;
745 if ($package =~ s/^src://) {
750 if (defined $package and $isbinary) {
751 my @srcinfo = binary_to_source(binary => $package,
752 version => $version);
754 # We know the source package(s). Use a fully-qualified version.
755 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
758 # Otherwise, an unqualified version will have to do.
762 # Strip off various kinds of brain-damage.
764 $version =~ s/ *\(.*\)//;
765 $version =~ s/ +[A-Za-z].*//;
767 foreach my $ver (split /[,\s]+/, $version) {
768 my $sver = defined($source) ? "$source/$ver" : '';
769 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
770 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
772 @{$data->{fixed_versions}} =
773 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
777 =head2 removefoundversions
779 removefoundversions($data,$package,$versiontoremove)
781 Removes found versions from $data
783 If a version is fully qualified (contains /) only versions matching
784 exactly are removed. Otherwise, all versions matching the version
787 Currently $package and $isbinary are entirely ignored, but accepted
788 for backwards compatibilty.
792 sub removefoundversions {
796 my $isbinary = shift;
797 return unless defined $version;
799 foreach my $ver (split /[,\s]+/, $version) {
801 # fully qualified version
802 @{$data->{found_versions}} =
804 @{$data->{found_versions}};
807 # non qualified version; delete all matchers
808 @{$data->{found_versions}} =
809 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
810 @{$data->{found_versions}};
816 sub addfixedversions {
820 my $isbinary = shift;
821 return unless defined $version;
822 undef $package if defined $package and $package =~ m[(?:\s|/)];
823 my $source = $package;
825 if (defined $package and $isbinary) {
826 my @srcinfo = binary_to_source(binary => $package,
827 version => $version);
829 # We know the source package(s). Use a fully-qualified version.
830 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
833 # Otherwise, an unqualified version will have to do.
837 # Strip off various kinds of brain-damage.
839 $version =~ s/ *\(.*\)//;
840 $version =~ s/ +[A-Za-z].*//;
842 foreach my $ver (split /[,\s]+/, $version) {
843 my $sver = defined($source) ? "$source/$ver" : '';
844 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
845 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
847 @{$data->{found_versions}} =
848 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
852 sub removefixedversions {
856 my $isbinary = shift;
857 return unless defined $version;
859 foreach my $ver (split /[,\s]+/, $version) {
861 # fully qualified version
862 @{$data->{fixed_versions}} =
864 @{$data->{fixed_versions}};
867 # non qualified version; delete all matchers
868 @{$data->{fixed_versions}} =
869 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
870 @{$data->{fixed_versions}};
881 Split a package string from the status file into a list of package names.
887 return unless defined $pkgs;
888 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
892 =head2 bug_archiveable
894 bug_archiveable(bug => $bug_num);
900 =item bug -- bug number (required)
902 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
904 =item version -- Debbugs::Version information (optional)
906 =item days_until -- return days until the bug can be archived
910 Returns 1 if the bug can be archived
911 Returns 0 if the bug cannot be archived
913 If days_until is true, returns the number of days until the bug can be
914 archived, -1 if it cannot be archived. 0 means that the bug can be
915 archived the next time the archiver runs.
917 Returns undef on failure.
921 # This will eventually need to be fixed before we start using mod_perl
922 our $version_cache = {};
924 my %param = validate_with(params => \@_,
925 spec => {bug => {type => SCALAR,
928 status => {type => HASHREF,
931 days_until => {type => BOOLEAN,
934 ignore_time => {type => BOOLEAN,
939 # This is what we return if the bug cannot be archived.
940 my $cannot_archive = $param{days_until}?-1:0;
941 # read the status information
942 my $status = $param{status};
943 if (not exists $param{status} or not defined $status) {
944 $status = read_bug(bug=>$param{bug});
945 if (not defined $status) {
946 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
950 # Bugs can be archived if they are
952 if (not defined $status->{done} or not length $status->{done}) {
953 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
954 return $cannot_archive
956 # Check to make sure that the bug has none of the unremovable tags set
957 if (@{$config{removal_unremovable_tags}}) {
958 for my $tag (split ' ', ($status->{keywords}||'')) {
959 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
960 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
961 return $cannot_archive;
966 # If we just are checking if the bug can be archived, we'll not even bother
967 # checking the versioning information if the bug has been -done for less than 28 days.
968 my $log_file = getbugcomponent($param{bug},'log');
969 if (not defined $log_file) {
970 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
971 return $cannot_archive;
973 my $max_log_age = max(map {$config{remove_age} - -M $_}
974 $log_file, map {my $log = getbugcomponent($_,'log');
975 defined $log ? ($log) : ();
977 split / /, $status->{mergedwith}
979 if (not $param{days_until} and not $param{ignore_time}
982 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
983 return $cannot_archive;
985 # At this point, we have to get the versioning information for this bug.
986 # We examine the set of distribution tags. If a bug has no distribution
987 # tags set, we assume a default set, otherwise we use the tags the bug
990 # In cases where we are assuming a default set, if the severity
991 # is strong, we use the strong severity default; otherwise, we
992 # use the normal default.
994 # There must be fixed_versions for us to look at the versioning
996 my $min_fixed_time = time;
997 my $min_archive_days = 0;
998 if (@{$status->{fixed_versions}}) {
1000 @dist_tags{@{$config{removal_distribution_tags}}} =
1001 (1) x @{$config{removal_distribution_tags}};
1003 for my $tag (split ' ', ($status->{keywords}||'')) {
1004 next unless exists $config{distribution_aliases}{$tag};
1005 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1006 $dists{$config{distribution_aliases}{$tag}} = 1;
1008 if (not keys %dists) {
1009 if (isstrongseverity($status->{severity})) {
1010 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1011 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1014 @dists{@{$config{removal_default_distribution_tags}}} =
1015 (1) x @{$config{removal_default_distribution_tags}};
1018 my %source_versions;
1019 my @sourceversions = get_versions(package => $status->{package},
1020 dist => [keys %dists],
1023 @source_versions{@sourceversions} = (1) x @sourceversions;
1024 # If the bug has not been fixed in the versions actually
1025 # distributed, then it cannot be archived.
1026 if ('found' eq max_buggy(bug => $param{bug},
1027 sourceversions => [keys %source_versions],
1028 found => $status->{found_versions},
1029 fixed => $status->{fixed_versions},
1030 version_cache => $version_cache,
1031 package => $status->{package},
1033 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1034 return $cannot_archive;
1036 # Since the bug has at least been fixed in the architectures
1037 # that matters, we check to see how long it has been fixed.
1039 # If $param{ignore_time}, then we should ignore time.
1040 if ($param{ignore_time}) {
1041 return $param{days_until}?0:1;
1044 # To do this, we order the times from most recent to oldest;
1045 # when we come to the first found version, we stop.
1046 # If we run out of versions, we only report the time of the
1048 my %time_versions = get_versions(package => $status->{package},
1049 dist => [keys %dists],
1053 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1054 my $buggy = buggy(bug => $param{bug},
1055 version => $version,
1056 found => $status->{found_versions},
1057 fixed => $status->{fixed_versions},
1058 version_cache => $version_cache,
1059 package => $status->{package},
1061 last if $buggy eq 'found';
1062 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1064 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1065 # if there are no versions in the archive at all, then
1066 # we can archive if enough days have passed
1069 # If $param{ignore_time}, then we should ignore time.
1070 if ($param{ignore_time}) {
1071 return $param{days_until}?0:1;
1073 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1074 my $age = ceil($max_log_age);
1075 if ($age > 0 or $min_archive_days > 0) {
1076 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1077 return $param{days_until}?max($age,$min_archive_days):0;
1080 return $param{days_until}?0:1;
1085 =head2 get_bug_status
1087 my $status = get_bug_status(bug => $nnn);
1089 my $status = get_bug_status($bug_num)
1095 =item bug -- scalar bug number
1097 =item status -- optional hashref of bug status as returned by readbug
1098 (can be passed to avoid rereading the bug information)
1100 =item bug_index -- optional tied index of bug status infomration;
1101 currently not correctly implemented.
1103 =item version -- optional version(s) to check package status at
1105 =item dist -- optional distribution(s) to check package status at
1107 =item arch -- optional architecture(s) to check package status at
1109 =item bugusertags -- optional hashref of bugusertags
1111 =item sourceversion -- optional arrayref of source/version; overrides
1112 dist, arch, and version. [The entries in this array must be in the
1113 "source/version" format.] Eventually this can be used to for caching.
1115 =item indicatesource -- if true, indicate which source packages this
1116 bug could belong to (or does belong to in the case of bugs assigned to
1117 a source package). Defaults to true.
1121 Note: Currently the version information is cached; this needs to be
1122 changed before using this function in long lived programs.
1126 sub get_bug_status {
1130 my %param = validate_with(params => \@_,
1131 spec => {bug => {type => SCALAR,
1134 status => {type => HASHREF,
1137 bug_index => {type => OBJECT,
1140 version => {type => SCALAR|ARRAYREF,
1143 dist => {type => SCALAR|ARRAYREF,
1146 arch => {type => SCALAR|ARRAYREF,
1149 bugusertags => {type => HASHREF,
1152 sourceversions => {type => ARRAYREF,
1155 indicatesource => {type => BOOLEAN,
1162 if (defined $param{bug_index} and
1163 exists $param{bug_index}{$param{bug}}) {
1164 %status = %{ $param{bug_index}{$param{bug}} };
1165 $status{pending} = $status{ status };
1166 $status{id} = $param{bug};
1169 if (defined $param{status}) {
1170 %status = %{$param{status}};
1173 my $location = getbuglocation($param{bug}, 'summary');
1174 return {} if not defined $location or not length $location;
1175 %status = %{ readbug( $param{bug}, $location ) };
1177 $status{id} = $param{bug};
1179 if (defined $param{bugusertags}{$param{bug}}) {
1180 $status{keywords} = "" unless defined $status{keywords};
1181 $status{keywords} .= " " unless $status{keywords} eq "";
1182 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1184 $status{tags} = $status{keywords};
1185 my %tags = map { $_ => 1 } split ' ', $status{tags};
1187 $status{package} = '' if not defined $status{package};
1188 $status{"package"} =~ s/\s*$//;
1190 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1194 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1195 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1197 $status{"pending"} = 'pending';
1198 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1199 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1200 $status{"pending"} = 'fixed' if ($tags{fixed});
1203 my $presence = bug_presence(status => \%status,
1204 map{(exists $param{$_})?($_,$param{$_}):()}
1205 qw(bug sourceversions arch dist version found fixed package)
1207 if (defined $presence) {
1208 if ($presence eq 'fixed') {
1209 $status{pending} = 'done';
1211 elsif ($presence eq 'absent') {
1212 $status{pending} = 'absent';
1220 my $precence = bug_presence(bug => nnn,
1224 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1225 is found, absent, fixed, or no information is available in the
1226 distribution (dist) and/or architecture (arch) specified.
1233 =item bug -- scalar bug number
1235 =item status -- optional hashref of bug status as returned by readbug
1236 (can be passed to avoid rereading the bug information)
1238 =item bug_index -- optional tied index of bug status infomration;
1239 currently not correctly implemented.
1241 =item version -- optional version to check package status at
1243 =item dist -- optional distribution to check package status at
1245 =item arch -- optional architecture to check package status at
1247 =item sourceversion -- optional arrayref of source/version; overrides
1248 dist, arch, and version. [The entries in this array must be in the
1249 "source/version" format.] Eventually this can be used to for caching.
1256 my %param = validate_with(params => \@_,
1257 spec => {bug => {type => SCALAR,
1260 status => {type => HASHREF,
1263 version => {type => SCALAR|ARRAYREF,
1266 dist => {type => SCALAR|ARRAYREF,
1269 arch => {type => SCALAR|ARRAYREF,
1272 sourceversions => {type => ARRAYREF,
1278 if (defined $param{status}) {
1279 %status = %{$param{status}};
1282 my $location = getbuglocation($param{bug}, 'summary');
1283 return {} if not length $location;
1284 %status = %{ readbug( $param{bug}, $location ) };
1288 my $pseudo_desc = getpseudodesc();
1289 if (not exists $param{sourceversions}) {
1291 # pseudopackages do not have source versions by definition.
1292 if (exists $pseudo_desc->{$status{package}}) {
1295 elsif (defined $param{version}) {
1296 foreach my $arch (make_list($param{arch})) {
1297 for my $package (split /\s*,\s*/, $status{package}) {
1298 my @temp = makesourceversions($package,
1300 make_list($param{version})
1302 @sourceversions{@temp} = (1) x @temp;
1305 } elsif (defined $param{dist}) {
1306 my %affects_distribution_tags;
1307 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1308 (1) x @{$config{affects_distribution_tags}};
1309 my $some_distributions_disallowed = 0;
1310 my %allowed_distributions;
1311 for my $tag (split ' ', ($status{keywords}||'')) {
1312 if (exists $config{distribution_aliases}{$tag} and
1313 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1314 $some_distributions_disallowed = 1;
1315 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1317 elsif (exists $affects_distribution_tags{$tag}) {
1318 $some_distributions_disallowed = 1;
1319 $allowed_distributions{$tag} = 1;
1322 my @archs = make_list(exists $param{arch}?$param{arch}:());
1323 GET_SOURCE_VERSIONS:
1324 foreach my $arch (@archs) {
1325 for my $package (split /\s*,\s*/, $status{package}) {
1328 if ($package =~ /^src:(.+)$/) {
1332 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1333 # if some distributions are disallowed,
1334 # and this isn't an allowed
1335 # distribution, then we ignore this
1336 # distribution for the purposees of
1338 if ($some_distributions_disallowed and
1339 not exists $allowed_distributions{$dist}) {
1342 push @versions, get_versions(package => $package,
1344 ($source?(arch => 'source'):
1345 (defined $arch?(arch => $arch):())),
1348 next unless @versions;
1349 my @temp = make_source_versions(package => $package,
1351 versions => \@versions,
1353 @sourceversions{@temp} = (1) x @temp;
1356 # this should really be split out into a subroutine,
1357 # but it'd touch so many things currently, that we fake
1358 # it; it's needed to properly handle bugs which are
1359 # erroneously assigned to the binary package, and we'll
1360 # probably have it go away eventually.
1361 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1363 goto GET_SOURCE_VERSIONS;
1367 # TODO: This should probably be handled further out for efficiency and
1368 # for more ease of distinguishing between pkg= and src= queries.
1369 # DLA: src= queries should just pass arch=source, and they'll be happy.
1370 @sourceversions = keys %sourceversions;
1373 @sourceversions = @{$param{sourceversions}};
1375 my $maxbuggy = 'undef';
1376 if (@sourceversions) {
1377 $maxbuggy = max_buggy(bug => $param{bug},
1378 sourceversions => \@sourceversions,
1379 found => $status{found_versions},
1380 fixed => $status{fixed_versions},
1381 package => $status{package},
1382 version_cache => $version_cache,
1385 elsif (defined $param{dist} and
1386 not exists $pseudo_desc->{$status{package}}) {
1389 if (length($status{done}) and
1390 (not @sourceversions or not @{$status{fixed_versions}})) {
1405 =item bug -- scalar bug number
1407 =item sourceversion -- optional arrayref of source/version; overrides
1408 dist, arch, and version. [The entries in this array must be in the
1409 "source/version" format.] Eventually this can be used to for caching.
1413 Note: Currently the version information is cached; this needs to be
1414 changed before using this function in long lived programs.
1419 my %param = validate_with(params => \@_,
1420 spec => {bug => {type => SCALAR,
1423 sourceversions => {type => ARRAYREF,
1426 found => {type => ARRAYREF,
1429 fixed => {type => ARRAYREF,
1432 package => {type => SCALAR,
1434 version_cache => {type => HASHREF,
1439 # Resolve bugginess states (we might be looking at multiple
1440 # architectures, say). Found wins, then fixed, then absent.
1441 my $maxbuggy = 'absent';
1442 for my $package (split /\s*,\s*/, $param{package}) {
1443 for my $version (@{$param{sourceversions}}) {
1444 my $buggy = buggy(bug => $param{bug},
1445 version => $version,
1446 found => $param{found},
1447 fixed => $param{fixed},
1448 version_cache => $param{version_cache},
1449 package => $package,
1451 if ($buggy eq 'found') {
1453 } elsif ($buggy eq 'fixed') {
1454 $maxbuggy = 'fixed';
1471 Returns the output of Debbugs::Versions::buggy for a particular
1472 package, version and found/fixed set. Automatically turns found, fixed
1473 and version into source/version strings.
1475 Caching can be had by using the version_cache, but no attempt to check
1476 to see if the on disk information is more recent than the cache is
1477 made. [This will need to be fixed for long-lived processes.]
1482 my %param = validate_with(params => \@_,
1483 spec => {bug => {type => SCALAR,
1486 found => {type => ARRAYREF,
1489 fixed => {type => ARRAYREF,
1492 version_cache => {type => HASHREF,
1495 package => {type => SCALAR,
1497 version => {type => SCALAR,
1501 my @found = @{$param{found}};
1502 my @fixed = @{$param{fixed}};
1503 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1504 # We have non-source version versions
1505 @found = makesourceversions($param{package},undef,
1508 @fixed = makesourceversions($param{package},undef,
1512 if ($param{version} !~ m{/}) {
1513 my ($version) = makesourceversions($param{package},undef,
1516 $param{version} = $version if defined $version;
1518 # Figure out which source packages we need
1520 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1521 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1522 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1523 $param{version} =~ m{/};
1525 if (not defined $param{version_cache} or
1526 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1527 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1528 foreach my $source (keys %sources) {
1529 my $srchash = substr $source, 0, 1;
1530 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1531 if (not defined $version_fh) {
1532 # We only want to warn if it's a package which actually has a maintainer
1533 my $maints = getmaintainers();
1534 next if not exists $maints->{$source};
1535 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1538 $version->load($version_fh);
1540 if (defined $param{version_cache}) {
1541 $param{version_cache}{join(',',sort keys %sources)} = $version;
1545 $version = $param{version_cache}{join(',',sort keys %sources)};
1547 return $version->buggy($param{version},\@found,\@fixed);
1550 sub isstrongseverity {
1551 my $severity = shift;
1552 $severity = $config{default_severity} if
1553 not defined $severity or $severity eq '';
1554 return grep { $_ eq $severity } @{$config{strong_severities}};
1558 =head1 PRIVATE FUNCTIONS
1562 sub update_realtime {
1563 my ($file, %bugs) = @_;
1565 # update realtime index.db
1567 return () unless keys %bugs;
1568 my $idx_old = IO::File->new($file,'r')
1569 or die "Couldn't open ${file}: $!";
1570 my $idx_new = IO::File->new($file.'.new','w')
1571 or die "Couldn't open ${file}.new: $!";
1573 my $min_bug = min(keys %bugs);
1577 while($line = <$idx_old>) {
1578 @line = split /\s/, $line;
1579 # Two cases; replacing existing line or adding new line
1580 if (exists $bugs{$line[1]}) {
1581 my $new = $bugs{$line[1]};
1582 delete $bugs{$line[1]};
1583 $min_bug = min(keys %bugs);
1584 if ($new eq "NOCHANGE") {
1585 print {$idx_new} $line;
1586 $changed_bugs{$line[1]} = $line;
1587 } elsif ($new eq "REMOVE") {
1588 $changed_bugs{$line[1]} = $line;
1590 print {$idx_new} $new;
1591 $changed_bugs{$line[1]} = $line;
1595 while ($line[1] > $min_bug) {
1596 print {$idx_new} $bugs{$min_bug};
1597 delete $bugs{$min_bug};
1598 last unless keys %bugs;
1599 $min_bug = min(keys %bugs);
1601 print {$idx_new} $line;
1603 last unless keys %bugs;
1605 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1607 print {$idx_new} <$idx_old>;
1612 rename("$file.new", $file);
1614 return %changed_bugs;
1617 sub bughook_archive {
1619 filelock("$config{spool_dir}/debbugs.trace.lock");
1620 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1621 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1622 map{($_,'REMOVE')} @refs);
1623 update_realtime("$config{spool_dir}/index.archive.realtime",
1629 my ( $type, %bugs_temp ) = @_;
1630 filelock("$config{spool_dir}/debbugs.trace.lock");
1633 for my $bug (keys %bugs_temp) {
1634 my $data = $bugs_temp{$bug};
1635 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1637 my $whendone = "open";
1638 my $severity = $config{default_severity};
1639 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1640 $pkglist =~ s/^,+//;
1641 $pkglist =~ s/,+$//;
1642 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1643 $whendone = "done" if defined $data->{done} and length $data->{done};
1644 $severity = $data->{severity} if length $data->{severity};
1646 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1647 $pkglist, $bug, $data->{date}, $whendone,
1648 $data->{originator}, $severity, $data->{keywords};
1651 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);