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 Exporter qw(import);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(:util :lock :quit :misc);
42 use Debbugs::Config qw(:config);
43 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
44 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
45 use Debbugs::Versions;
46 use Debbugs::Versions::Dpkg;
48 use File::Copy qw(copy);
49 use Encode qw(decode encode is_utf8);
51 use Storable qw(dclone);
52 use List::Util qw(min max);
58 $DEBUG = 0 unless defined $DEBUG;
61 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
62 qw(isstrongseverity bug_presence split_status_fields),
64 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
65 qw(lock_read_all_merged_bugs),
67 write => [qw(writebug makestatus unlockwritebug)],
69 versions => [qw(addfoundversions addfixedversions),
70 qw(removefoundversions removefixedversions)
72 hook => [qw(bughook bughook_archive)],
73 indexdb => [qw(generate_index_db_line)],
74 fields => [qw(%fields)],
77 Exporter::export_ok_tags(keys %EXPORT_TAGS);
78 $EXPORT_TAGS{all} = [@EXPORT_OK];
84 readbug($bug_num,$location)
87 Reads a summary file from the archive given a bug number and a bug
88 location. Valid locations are those understood by L</getbugcomponent>
92 # these probably shouldn't be imported by most people, but
93 # Debbugs::Control needs them, so they're now exportable
94 our %fields = (originator => 'submitter',
97 msgid => 'message-id',
98 'package' => 'package',
101 forwarded => 'forwarded-to',
102 mergedwith => 'merged-with',
103 severity => 'severity',
105 found_versions => 'found-in',
106 found_date => 'found-date',
107 fixed_versions => 'fixed-in',
108 fixed_date => 'fixed-date',
110 blockedby => 'blocked-by',
111 unarchived => 'unarchived',
112 summary => 'summary',
113 outlook => 'outlook',
114 affects => 'affects',
118 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
119 my @rfc1522_fields = qw(originator subject done forwarded owner);
122 return read_bug(bug => $_[0],
123 (@_ > 1)?(location => $_[1]):()
129 read_bug(bug => $bug_num,
130 location => 'archive',
132 read_bug(summary => 'path/to/bugnum.summary');
135 A more complete function than readbug; it enables you to pass a full
136 path to the summary file instead of the bug number and/or location.
142 =item bug -- the bug number
144 =item location -- optional location which is passed to getbugcomponent
146 =item summary -- complete path to the .summary file which will be read
148 =item lock -- whether to obtain a lock for the bug to prevent
149 something modifying it while the bug has been read. You B<must> call
150 C<unfilelock();> if something not undef is returned from read_bug.
152 =item locks -- hashref of already obtained locks; incremented as new
153 locks are needed, and decremented as locks are released on particular
158 One of C<bug> or C<summary> must be passed. This function will return
159 undef on failure, and will die if improper arguments are passed.
167 my %param = validate_with(params => \@_,
168 spec => {bug => {type => SCALAR,
172 # negative bugnumbers
175 location => {type => SCALAR|UNDEF,
178 summary => {type => SCALAR,
181 lock => {type => BOOLEAN,
184 locks => {type => HASHREF,
189 die "One of bug or summary must be passed to read_bug"
190 if not exists $param{bug} and not exists $param{summary};
194 if (not defined $param{summary}) {
196 ($lref,$location) = @param{qw(bug location)};
197 if (not defined $location) {
198 $location = getbuglocation($lref,'summary');
199 return undef if not defined $location;
201 $status = getbugcomponent($lref, 'summary', $location);
202 $log = getbugcomponent($lref, 'log' , $location);
203 return undef unless defined $status;
204 return undef if not -e $status;
207 $status = $param{summary};
209 $log =~ s/\.summary$/.log/;
210 ($location) = $status =~ m/(db-h|db|archive)/;
211 ($param{bug}) = $status =~ m/(\d+)\.summary$/;
214 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
216 my $status_fh = IO::File->new($status, 'r');
217 if (not defined $status_fh) {
218 warn "Unable to open $status for reading: $!";
220 unfilelock(exists $param{locks}?$param{locks}:());
224 binmode($status_fh,':encoding(UTF-8)');
231 while (<$status_fh>) {
234 $version = $1 if /^Format-Version: ([0-9]+)/i;
237 # Version 3 is the latest format version currently supported.
239 warn "Unsupported status version '$version'";
241 unfilelock(exists $param{locks}?$param{locks}:());
246 my %namemap = reverse %fields;
247 for my $line (@lines) {
248 if ($line =~ /(\S+?): (.*)/) {
249 my ($name, $value) = (lc $1, $2);
250 # this is a bit of a hack; we should never, ever have \r
251 # or \n in the fields of status. Kill them off here.
252 # [Eventually, this should be superfluous.]
253 $value =~ s/[\r\n]//g;
254 $data{$namemap{$name}} = $value if exists $namemap{$name};
257 for my $field (keys %fields) {
258 $data{$field} = '' unless exists $data{$field};
261 for my $field (@rfc1522_fields) {
262 $data{$field} = decode_rfc1522($data{$field});
265 $data{severity} = $config{default_severity} if $data{severity} eq '';
266 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
267 $data{$field} = [split ' ', $data{$field}];
269 for my $field (qw(found fixed)) {
270 # create the found/fixed hashes which indicate when a
271 # particular version was marked found or marked fixed.
272 @{$data{$field}}{@{$data{"${field}_versions"}}} =
273 (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}),
274 @{$data{"${field}_date"}});
277 my $status_modified = (stat($status))[9];
278 # Add log last modified time
279 $data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9];
280 $data{last_modified} = max($status_modified,$data{log_modified});
281 $data{location} = $location;
282 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
283 $data{bug_num} = $param{bug};
288 =head2 split_status_fields
290 my @data = split_status_fields(@data);
292 Splits splittable status fields (like package, tags, blocks,
293 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
294 passed @data intact using dclone.
296 In scalar context, returns only the first element of @data.
300 our $ditch_empty = sub{
302 my $splitter = shift @t;
303 return grep {length $_} map {split $splitter} @t;
306 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
308 (package => \&splitpackages,
309 affects => \&splitpackages,
310 # Ideally we won't have to split source, but because some consumers of
311 # get_bug_status cannot handle arrayref, we will split it here.
312 source => \&splitpackages,
313 blocks => $ditch_empty_space,
314 blockedby => $ditch_empty_space,
315 # this isn't strictly correct, but we'll split both of them for
316 # the time being until we ditch all use of keywords everywhere
318 keywords => $ditch_empty_space,
319 tags => $ditch_empty_space,
320 found_versions => $ditch_empty_space,
321 fixed_versions => $ditch_empty_space,
322 mergedwith => $ditch_empty_space,
325 sub split_status_fields {
326 my @data = @{dclone(\@_)};
327 for my $data (@data) {
328 next if not defined $data;
329 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
330 not (ref($data) and ref($data) eq 'HASH');
331 for my $field (keys %{$data}) {
332 next unless defined $data->{$field};
333 if (exists $split_fields{$field}) {
334 next if ref($data->{$field});
336 if (ref($split_fields{$field}) eq 'CODE') {
337 @elements = &{$split_fields{$field}}($data->{$field});
339 elsif (not ref($split_fields{$field}) or
340 UNIVERSAL::isa($split_fields{$field},'Regex')
342 @elements = split $split_fields{$field}, $data->{$field};
344 $data->{$field} = \@elements;
348 return wantarray?@data:$data[0];
351 =head2 join_status_fields
353 my @data = join_status_fields(@data);
355 Handles joining the splitable status fields. (Basically, the inverse
356 of split_status_fields.
358 Primarily called from makestatus, but may be useful for other
359 functions after calling split_status_fields (or for legacy functions
360 if we transition to split fields by default).
364 sub join_status_fields {
371 found_versions => ' ',
372 fixed_versions => ' ',
377 my @data = @{dclone(\@_)};
378 for my $data (@data) {
379 next if not defined $data;
380 croak "Passed an element which is not a hashref to split_status_field: ".
382 if ref($data) ne 'HASH';
383 for my $field (keys %{$data}) {
384 next unless defined $data->{$field};
385 next unless ref($data->{$field}) eq 'ARRAY';
386 next unless exists $join_fields{$field};
387 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
390 return wantarray?@data:$data[0];
396 lockreadbug($bug_num,$location)
398 Performs a filelock, then reads the bug; the bug is unlocked if the
399 return is undefined, otherwise, you need to call unfilelock or
402 See readbug above for information on what this returns
407 my ($lref, $location) = @_;
408 return read_bug(bug => $lref, location => $location, lock => 1);
411 =head2 lockreadbugmerge
413 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
415 Performs a filelock, then reads the bug. If the bug is merged, locks
416 the merge lock. Returns a list of the number of locks and the bug
421 sub lockreadbugmerge {
422 my $data = lockreadbug(@_);
423 if (not defined $data) {
426 if (not length $data->{mergedwith}) {
430 filelock("$config{spool_dir}/lock/merge");
431 $data = lockreadbug(@_);
432 if (not defined $data) {
439 =head2 lock_read_all_merged_bugs
441 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
443 Performs a filelock, then reads the bug passed. If the bug is merged,
444 locks the merge lock, then reads and locks all of the other merged
445 bugs. Returns a list of the number of locks and the bug data for all
448 Will also return undef if any of the merged bugs failed to be read,
449 even if all of the others were read properly.
453 sub lock_read_all_merged_bugs {
454 my %param = validate_with(params => \@_,
455 spec => {bug => {type => SCALAR,
458 location => {type => SCALAR,
461 locks => {type => HASHREF,
467 my @data = read_bug(bug => $param{bug},
469 exists $param{location} ? (location => $param{location}):(),
470 exists $param{locks} ? (locks => $param{locks}):(),
472 if (not @data or not defined $data[0]) {
476 if (not length $data[0]->{mergedwith}) {
477 return ($locks,@data);
479 unfilelock(exists $param{locks}?$param{locks}:());
481 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
483 @data = read_bug(bug => $param{bug},
485 exists $param{location} ? (location => $param{location}):(),
486 exists $param{locks} ? (locks => $param{locks}):(),
488 if (not @data or not defined $data[0]) {
489 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
494 my @bugs = split / /, $data[0]->{mergedwith};
495 push @bugs, $param{bug};
496 for my $bug (@bugs) {
498 if ($bug != $param{bug}) {
500 read_bug(bug => $bug,
502 exists $param{location} ? (location => $param{location}):(),
503 exists $param{locks} ? (locks => $param{locks}):(),
505 if (not defined $newdata) {
507 unfilelock(exists $param{locks}?$param{locks}:());
510 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
515 # perform a sanity check to make sure that the merged bugs
516 # are all merged with eachother
517 # We do a cmp sort instead of an <=> sort here, because that's
519 my $expectmerge= join(' ',grep {$_ != $bug } sort @bugs);
520 if ($newdata->{mergedwith} ne $expectmerge) {
522 unfilelock(exists $param{locks}?$param{locks}:());
524 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
528 return ($locks,@data);
533 my $new_bug_num = new_bug(copy => $data->{bug_num});
535 Creates a new bug and returns the new bug number upon success.
543 validate_with(params => \@_,
544 spec => {copy => {type => SCALAR,
550 filelock("nextnumber.lock");
551 my $nn_fh = IO::File->new("nextnumber",'r') or
552 die "Unable to open nextnuber for reading: $!";
555 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
557 overwritefile("nextnumber",
560 my $nn_hash = get_hashname($nn);
562 my $c_hash = get_hashname($param{copy});
563 for my $file (qw(log status summary report)) {
564 copy("db-h/$c_hash/$param{copy}.$file",
565 "db-h/$nn_hash/${nn}.$file")
569 for my $file (qw(log status summary report)) {
570 overwritefile("db-h/$nn_hash/${nn}.$file",
575 # this probably needs to be munged to do something more elegant
576 # &bughook('new', $clone, $data);
583 my @v1fieldorder = qw(originator date subject msgid package
584 keywords done forwarded mergedwith severity);
588 my $content = makestatus($status,$version)
589 my $content = makestatus($status);
591 Creates the content for a status file based on the $status hashref
594 Really only useful for writebug
596 Currently defaults to version 2 (non-encoded rfc1522 names) but will
597 eventually default to version 3. If you care, you should specify a
603 my ($data,$version) = @_;
604 $version = 3 unless defined $version;
608 my %newdata = %$data;
609 for my $field (qw(found fixed)) {
610 if (exists $newdata{$field}) {
611 $newdata{"${field}_date"} =
612 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
615 %newdata = %{join_status_fields(\%newdata)};
617 %newdata = encode_utf8_structure(%newdata);
620 for my $field (@rfc1522_fields) {
621 $newdata{$field} = encode_rfc1522($newdata{$field});
625 # this is a bit of a hack; we should never, ever have \r or \n in
626 # the fields of status. Kill them off here. [Eventually, this
627 # should be superfluous.]
628 for my $field (keys %newdata) {
629 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
633 for my $field (@v1fieldorder) {
634 if (exists $newdata{$field} and defined $newdata{$field}) {
635 $contents .= "$newdata{$field}\n";
640 } elsif ($version == 2 or $version == 3) {
641 # Version 2 or 3. Add a file format version number for the sake of
642 # further extensibility in the future.
643 $contents .= "Format-Version: $version\n";
644 for my $field (keys %fields) {
645 if (exists $newdata{$field} and defined $newdata{$field}
646 and $newdata{$field} ne '') {
647 # Output field names in proper case, e.g. 'Merged-With'.
648 my $properfield = $fields{$field};
649 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
650 my $data = $newdata{$field};
651 $contents .= "$properfield: $data\n";
660 writebug($bug_num,$status,$location,$minversion,$disablebughook)
662 Writes the bug status and summary files out.
664 Skips writing out a status file if minversion is 2
666 Does not call bughook if disablebughook is true.
671 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
674 my %outputs = (1 => 'status', 3 => 'summary');
675 for my $version (keys %outputs) {
676 next if defined $minversion and $version < $minversion;
677 my $status = getbugcomponent($ref, $outputs{$version}, $location);
678 die "can't find location for $ref" unless defined $status;
681 open $sfh,">","$status.new" or
682 die "opening $status.new: $!";
685 open $sfh,">","$status.new" or
686 die "opening $status.new: $!";
688 print {$sfh} makestatus($data, $version) or
689 die "writing $status.new: $!";
690 close($sfh) or die "closing $status.new: $!";
696 rename("$status.new",$status) || die "installing new $status: $!";
699 # $disablebughook is a bit of a hack to let format migration scripts use
700 # this function rather than having to duplicate it themselves.
701 &bughook($change,$ref,$data) unless $disablebughook;
704 =head2 unlockwritebug
706 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
708 Writes a bug, then calls unfilelock; see writebug for what these
720 The following functions are exported with the :versions tag
722 =head2 addfoundversions
724 addfoundversions($status,$package,$version,$isbinary);
726 All use of this should be phased out in favor of Debbugs::Control::fixed/found
731 sub addfoundversions {
735 my $isbinary = shift;
736 return unless defined $version;
737 undef $package if defined $package and $package =~ m[(?:\s|/)];
738 my $source = $package;
739 if (defined $package and $package =~ s/^src://) {
744 if (defined $package and $isbinary) {
745 my @srcinfo = binary_to_source(binary => $package,
746 version => $version);
748 # We know the source package(s). Use a fully-qualified version.
749 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
752 # Otherwise, an unqualified version will have to do.
756 # Strip off various kinds of brain-damage.
758 $version =~ s/ *\(.*\)//;
759 $version =~ s/ +[A-Za-z].*//;
761 foreach my $ver (split /[,\s]+/, $version) {
762 my $sver = defined($source) ? "$source/$ver" : '';
763 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
764 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
766 @{$data->{fixed_versions}} =
767 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
771 =head2 removefoundversions
773 removefoundversions($data,$package,$versiontoremove)
775 Removes found versions from $data
777 If a version is fully qualified (contains /) only versions matching
778 exactly are removed. Otherwise, all versions matching the version
781 Currently $package and $isbinary are entirely ignored, but accepted
782 for backwards compatibility.
786 sub removefoundversions {
790 my $isbinary = shift;
791 return unless defined $version;
793 foreach my $ver (split /[,\s]+/, $version) {
795 # fully qualified version
796 @{$data->{found_versions}} =
798 @{$data->{found_versions}};
801 # non qualified version; delete all matchers
802 @{$data->{found_versions}} =
803 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
804 @{$data->{found_versions}};
810 sub addfixedversions {
814 my $isbinary = shift;
815 return unless defined $version;
816 undef $package if defined $package and $package =~ m[(?:\s|/)];
817 my $source = $package;
819 if (defined $package and $isbinary) {
820 my @srcinfo = binary_to_source(binary => $package,
821 version => $version);
823 # We know the source package(s). Use a fully-qualified version.
824 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
827 # Otherwise, an unqualified version will have to do.
831 # Strip off various kinds of brain-damage.
833 $version =~ s/ *\(.*\)//;
834 $version =~ s/ +[A-Za-z].*//;
836 foreach my $ver (split /[,\s]+/, $version) {
837 my $sver = defined($source) ? "$source/$ver" : '';
838 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
839 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
841 @{$data->{found_versions}} =
842 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
846 sub removefixedversions {
850 my $isbinary = shift;
851 return unless defined $version;
853 foreach my $ver (split /[,\s]+/, $version) {
855 # fully qualified version
856 @{$data->{fixed_versions}} =
858 @{$data->{fixed_versions}};
861 # non qualified version; delete all matchers
862 @{$data->{fixed_versions}} =
863 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
864 @{$data->{fixed_versions}};
875 Split a package string from the status file into a list of package names.
881 return unless defined $pkgs;
882 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
886 =head2 bug_archiveable
888 bug_archiveable(bug => $bug_num);
894 =item bug -- bug number (required)
896 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
898 =item version -- Debbugs::Version information (optional)
900 =item days_until -- return days until the bug can be archived
904 Returns 1 if the bug can be archived
905 Returns 0 if the bug cannot be archived
907 If days_until is true, returns the number of days until the bug can be
908 archived, -1 if it cannot be archived. 0 means that the bug can be
909 archived the next time the archiver runs.
911 Returns undef on failure.
915 # This will eventually need to be fixed before we start using mod_perl
916 our $version_cache = {};
918 my %param = validate_with(params => \@_,
919 spec => {bug => {type => SCALAR,
922 status => {type => HASHREF,
925 days_until => {type => BOOLEAN,
928 ignore_time => {type => BOOLEAN,
933 # This is what we return if the bug cannot be archived.
934 my $cannot_archive = $param{days_until}?-1:0;
935 # read the status information
936 my $status = $param{status};
937 if (not exists $param{status} or not defined $status) {
938 $status = read_bug(bug=>$param{bug});
939 if (not defined $status) {
940 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
944 # Bugs can be archived if they are
946 if (not defined $status->{done} or not length $status->{done}) {
947 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
948 return $cannot_archive
950 # Check to make sure that the bug has none of the unremovable tags set
951 if (@{$config{removal_unremovable_tags}}) {
952 for my $tag (split ' ', ($status->{keywords}||'')) {
953 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
954 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
955 return $cannot_archive;
960 # If we just are checking if the bug can be archived, we'll not even bother
961 # checking the versioning information if the bug has been -done for less than 28 days.
962 my $log_file = getbugcomponent($param{bug},'log');
963 if (not defined $log_file) {
964 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
965 return $cannot_archive;
967 my $max_log_age = max(map {$config{remove_age} - -M $_}
968 $log_file, map {my $log = getbugcomponent($_,'log');
969 defined $log ? ($log) : ();
971 split / /, $status->{mergedwith}
973 if (not $param{days_until} and not $param{ignore_time}
976 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
977 return $cannot_archive;
979 # At this point, we have to get the versioning information for this bug.
980 # We examine the set of distribution tags. If a bug has no distribution
981 # tags set, we assume a default set, otherwise we use the tags the bug
984 # In cases where we are assuming a default set, if the severity
985 # is strong, we use the strong severity default; otherwise, we
986 # use the normal default.
988 # There must be fixed_versions for us to look at the versioning
990 my $min_fixed_time = time;
991 my $min_archive_days = 0;
992 if (@{$status->{fixed_versions}}) {
994 @dist_tags{@{$config{removal_distribution_tags}}} =
995 (1) x @{$config{removal_distribution_tags}};
997 for my $tag (split ' ', ($status->{keywords}||'')) {
998 next unless exists $config{distribution_aliases}{$tag};
999 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1000 $dists{$config{distribution_aliases}{$tag}} = 1;
1002 if (not keys %dists) {
1003 if (isstrongseverity($status->{severity})) {
1004 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1005 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1008 @dists{@{$config{removal_default_distribution_tags}}} =
1009 (1) x @{$config{removal_default_distribution_tags}};
1012 my %source_versions;
1013 my @sourceversions = get_versions(package => $status->{package},
1014 dist => [keys %dists],
1017 @source_versions{@sourceversions} = (1) x @sourceversions;
1018 # If the bug has not been fixed in the versions actually
1019 # distributed, then it cannot be archived.
1020 if ('found' eq max_buggy(bug => $param{bug},
1021 sourceversions => [keys %source_versions],
1022 found => $status->{found_versions},
1023 fixed => $status->{fixed_versions},
1024 version_cache => $version_cache,
1025 package => $status->{package},
1027 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1028 return $cannot_archive;
1030 # Since the bug has at least been fixed in the architectures
1031 # that matters, we check to see how long it has been fixed.
1033 # If $param{ignore_time}, then we should ignore time.
1034 if ($param{ignore_time}) {
1035 return $param{days_until}?0:1;
1038 # To do this, we order the times from most recent to oldest;
1039 # when we come to the first found version, we stop.
1040 # If we run out of versions, we only report the time of the
1042 my %time_versions = get_versions(package => $status->{package},
1043 dist => [keys %dists],
1047 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1048 my $buggy = buggy(bug => $param{bug},
1049 version => $version,
1050 found => $status->{found_versions},
1051 fixed => $status->{fixed_versions},
1052 version_cache => $version_cache,
1053 package => $status->{package},
1055 last if $buggy eq 'found';
1056 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1058 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1059 # if there are no versions in the archive at all, then
1060 # we can archive if enough days have passed
1063 # If $param{ignore_time}, then we should ignore time.
1064 if ($param{ignore_time}) {
1065 return $param{days_until}?0:1;
1067 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1068 my $age = ceil($max_log_age);
1069 if ($age > 0 or $min_archive_days > 0) {
1070 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1071 return $param{days_until}?max($age,$min_archive_days):0;
1074 return $param{days_until}?0:1;
1079 =head2 get_bug_status
1081 my $status = get_bug_status(bug => $nnn);
1083 my $status = get_bug_status($bug_num)
1089 =item bug -- scalar bug number
1091 =item status -- optional hashref of bug status as returned by readbug
1092 (can be passed to avoid rereading the bug information)
1094 =item bug_index -- optional tied index of bug status infomration;
1095 currently not correctly implemented.
1097 =item version -- optional version(s) to check package status at
1099 =item dist -- optional distribution(s) to check package status at
1101 =item arch -- optional architecture(s) to check package status at
1103 =item bugusertags -- optional hashref of bugusertags
1105 =item sourceversion -- optional arrayref of source/version; overrides
1106 dist, arch, and version. [The entries in this array must be in the
1107 "source/version" format.] Eventually this can be used to for caching.
1109 =item indicatesource -- if true, indicate which source packages this
1110 bug could belong to (or does belong to in the case of bugs assigned to
1111 a source package). Defaults to true.
1115 Note: Currently the version information is cached; this needs to be
1116 changed before using this function in long lived programs.
1120 Currently returns a hashref of status with the following keys.
1124 =item id -- bug number
1126 =item bug_num -- duplicate of id
1128 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1130 =item tags -- duplicate of keywords
1132 =item package -- name of package that the bug is assigned to
1134 =item severity -- severity of the bug
1136 =item pending -- pending state of the bug; one of following possible
1137 values; values listed later have precedence if multiple conditions are
1142 =item pending -- default state
1144 =item forwarded -- bug has been forwarded
1146 =item pending-fixed -- bug is tagged pending
1148 =item fixed -- bug is tagged fixed
1150 =item absent -- bug does not apply to this distribution/architecture
1152 =item done -- bug is resolved in this distribution/architecture
1156 =item location -- db-h or archive; the location in the filesystem
1158 =item subject -- title of the bug
1160 =item last_modified -- epoch that the bug was last modified
1162 =item date -- epoch that the bug was filed
1164 =item originator -- bug reporter
1166 =item log_modified -- epoch that the log file was last modified
1168 =item msgid -- Message id of the original bug report
1173 Other key/value pairs are returned but are not currently documented here.
1177 sub get_bug_status {
1181 my %param = validate_with(params => \@_,
1182 spec => {bug => {type => SCALAR,
1185 status => {type => HASHREF,
1188 bug_index => {type => OBJECT,
1191 version => {type => SCALAR|ARRAYREF,
1194 dist => {type => SCALAR|ARRAYREF,
1197 arch => {type => SCALAR|ARRAYREF,
1200 bugusertags => {type => HASHREF,
1203 sourceversions => {type => ARRAYREF,
1206 indicatesource => {type => BOOLEAN,
1213 if (defined $param{bug_index} and
1214 exists $param{bug_index}{$param{bug}}) {
1215 %status = %{ $param{bug_index}{$param{bug}} };
1216 $status{pending} = $status{ status };
1217 $status{id} = $param{bug};
1220 if (defined $param{status}) {
1221 %status = %{$param{status}};
1224 my $location = getbuglocation($param{bug}, 'summary');
1225 return {} if not defined $location or not length $location;
1226 %status = %{ readbug( $param{bug}, $location ) };
1228 $status{id} = $param{bug};
1230 if (defined $param{bugusertags}{$param{bug}}) {
1231 $status{keywords} = "" unless defined $status{keywords};
1232 $status{keywords} .= " " unless $status{keywords} eq "";
1233 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1235 $status{tags} = $status{keywords};
1236 my %tags = map { $_ => 1 } split ' ', $status{tags};
1238 $status{package} = '' if not defined $status{package};
1239 $status{"package"} =~ s/\s*$//;
1241 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1245 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1246 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1248 $status{"pending"} = 'pending';
1249 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1250 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1251 $status{"pending"} = 'fixed' if ($tags{fixed});
1254 my $presence = bug_presence(status => \%status,
1255 map{(exists $param{$_})?($_,$param{$_}):()}
1256 qw(bug sourceversions arch dist version found fixed package)
1258 if (defined $presence) {
1259 if ($presence eq 'fixed') {
1260 $status{pending} = 'done';
1262 elsif ($presence eq 'absent') {
1263 $status{pending} = 'absent';
1271 my $precence = bug_presence(bug => nnn,
1275 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1276 is found, absent, fixed, or no information is available in the
1277 distribution (dist) and/or architecture (arch) specified.
1284 =item bug -- scalar bug number
1286 =item status -- optional hashref of bug status as returned by readbug
1287 (can be passed to avoid rereading the bug information)
1289 =item bug_index -- optional tied index of bug status infomration;
1290 currently not correctly implemented.
1292 =item version -- optional version to check package status at
1294 =item dist -- optional distribution to check package status at
1296 =item arch -- optional architecture to check package status at
1298 =item sourceversion -- optional arrayref of source/version; overrides
1299 dist, arch, and version. [The entries in this array must be in the
1300 "source/version" format.] Eventually this can be used to for caching.
1307 my %param = validate_with(params => \@_,
1308 spec => {bug => {type => SCALAR,
1311 status => {type => HASHREF,
1314 version => {type => SCALAR|ARRAYREF,
1317 dist => {type => SCALAR|ARRAYREF,
1320 arch => {type => SCALAR|ARRAYREF,
1323 sourceversions => {type => ARRAYREF,
1329 if (defined $param{status}) {
1330 %status = %{$param{status}};
1333 my $location = getbuglocation($param{bug}, 'summary');
1334 return {} if not length $location;
1335 %status = %{ readbug( $param{bug}, $location ) };
1339 my $pseudo_desc = getpseudodesc();
1340 if (not exists $param{sourceversions}) {
1342 # pseudopackages do not have source versions by definition.
1343 if (exists $pseudo_desc->{$status{package}}) {
1346 elsif (defined $param{version}) {
1347 foreach my $arch (make_list($param{arch})) {
1348 for my $package (split /\s*,\s*/, $status{package}) {
1349 my @temp = makesourceversions($package,
1351 make_list($param{version})
1353 @sourceversions{@temp} = (1) x @temp;
1356 } elsif (defined $param{dist}) {
1357 my %affects_distribution_tags;
1358 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1359 (1) x @{$config{affects_distribution_tags}};
1360 my $some_distributions_disallowed = 0;
1361 my %allowed_distributions;
1362 for my $tag (split ' ', ($status{keywords}||'')) {
1363 if (exists $config{distribution_aliases}{$tag} and
1364 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1365 $some_distributions_disallowed = 1;
1366 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1368 elsif (exists $affects_distribution_tags{$tag}) {
1369 $some_distributions_disallowed = 1;
1370 $allowed_distributions{$tag} = 1;
1373 my @archs = make_list(exists $param{arch}?$param{arch}:());
1374 GET_SOURCE_VERSIONS:
1375 foreach my $arch (@archs) {
1376 for my $package (split /\s*,\s*/, $status{package}) {
1379 if ($package =~ /^src:(.+)$/) {
1383 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1384 # if some distributions are disallowed,
1385 # and this isn't an allowed
1386 # distribution, then we ignore this
1387 # distribution for the purposees of
1389 if ($some_distributions_disallowed and
1390 not exists $allowed_distributions{$dist}) {
1393 push @versions, get_versions(package => $package,
1395 ($source?(arch => 'source'):
1396 (defined $arch?(arch => $arch):())),
1399 next unless @versions;
1400 my @temp = make_source_versions(package => $package,
1402 versions => \@versions,
1404 @sourceversions{@temp} = (1) x @temp;
1407 # this should really be split out into a subroutine,
1408 # but it'd touch so many things currently, that we fake
1409 # it; it's needed to properly handle bugs which are
1410 # erroneously assigned to the binary package, and we'll
1411 # probably have it go away eventually.
1412 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1414 goto GET_SOURCE_VERSIONS;
1418 # TODO: This should probably be handled further out for efficiency and
1419 # for more ease of distinguishing between pkg= and src= queries.
1420 # DLA: src= queries should just pass arch=source, and they'll be happy.
1421 @sourceversions = keys %sourceversions;
1424 @sourceversions = @{$param{sourceversions}};
1426 my $maxbuggy = 'undef';
1427 if (@sourceversions) {
1428 $maxbuggy = max_buggy(bug => $param{bug},
1429 sourceversions => \@sourceversions,
1430 found => $status{found_versions},
1431 fixed => $status{fixed_versions},
1432 package => $status{package},
1433 version_cache => $version_cache,
1436 elsif (defined $param{dist} and
1437 not exists $pseudo_desc->{$status{package}}) {
1440 if (length($status{done}) and
1441 (not @sourceversions or not @{$status{fixed_versions}})) {
1456 =item bug -- scalar bug number
1458 =item sourceversion -- optional arrayref of source/version; overrides
1459 dist, arch, and version. [The entries in this array must be in the
1460 "source/version" format.] Eventually this can be used to for caching.
1464 Note: Currently the version information is cached; this needs to be
1465 changed before using this function in long lived programs.
1470 my %param = validate_with(params => \@_,
1471 spec => {bug => {type => SCALAR,
1474 sourceversions => {type => ARRAYREF,
1477 found => {type => ARRAYREF,
1480 fixed => {type => ARRAYREF,
1483 package => {type => SCALAR,
1485 version_cache => {type => HASHREF,
1490 # Resolve bugginess states (we might be looking at multiple
1491 # architectures, say). Found wins, then fixed, then absent.
1492 my $maxbuggy = 'absent';
1493 for my $package (split /\s*,\s*/, $param{package}) {
1494 for my $version (@{$param{sourceversions}}) {
1495 my $buggy = buggy(bug => $param{bug},
1496 version => $version,
1497 found => $param{found},
1498 fixed => $param{fixed},
1499 version_cache => $param{version_cache},
1500 package => $package,
1502 if ($buggy eq 'found') {
1504 } elsif ($buggy eq 'fixed') {
1505 $maxbuggy = 'fixed';
1522 Returns the output of Debbugs::Versions::buggy for a particular
1523 package, version and found/fixed set. Automatically turns found, fixed
1524 and version into source/version strings.
1526 Caching can be had by using the version_cache, but no attempt to check
1527 to see if the on disk information is more recent than the cache is
1528 made. [This will need to be fixed for long-lived processes.]
1533 my %param = validate_with(params => \@_,
1534 spec => {bug => {type => SCALAR,
1537 found => {type => ARRAYREF,
1540 fixed => {type => ARRAYREF,
1543 version_cache => {type => HASHREF,
1546 package => {type => SCALAR,
1548 version => {type => SCALAR,
1552 my @found = @{$param{found}};
1553 my @fixed = @{$param{fixed}};
1554 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1555 # We have non-source version versions
1556 @found = makesourceversions($param{package},undef,
1559 @fixed = makesourceversions($param{package},undef,
1563 if ($param{version} !~ m{/}) {
1564 my ($version) = makesourceversions($param{package},undef,
1567 $param{version} = $version if defined $version;
1569 # Figure out which source packages we need
1571 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1572 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1573 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1574 $param{version} =~ m{/};
1576 if (not defined $param{version_cache} or
1577 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1578 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1579 foreach my $source (keys %sources) {
1580 my $srchash = substr $source, 0, 1;
1581 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1582 if (not defined $version_fh) {
1583 # We only want to warn if it's a package which actually has a maintainer
1584 my $maints = getmaintainers();
1585 next if not exists $maints->{$source};
1586 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1589 $version->load($version_fh);
1591 if (defined $param{version_cache}) {
1592 $param{version_cache}{join(',',sort keys %sources)} = $version;
1596 $version = $param{version_cache}{join(',',sort keys %sources)};
1598 return $version->buggy($param{version},\@found,\@fixed);
1601 sub isstrongseverity {
1602 my $severity = shift;
1603 $severity = $config{default_severity} if
1604 not defined $severity or $severity eq '';
1605 return grep { $_ eq $severity } @{$config{strong_severities}};
1610 =head2 generate_index_db_line
1612 my $data = read_bug(bug => $bug,
1613 location => $initialdir);
1614 # generate_index_db_line hasn't been written yet at all.
1615 my $line = generate_index_db_line($data);
1617 Returns a line for a bug suitable to be written out to index.db.
1621 sub generate_index_db_line {
1622 my ($data,$bug) = @_;
1624 # just in case someone has given us a split out data
1625 $data = join_status_fields($data);
1627 my $whendone = "open";
1628 my $severity = $config{default_severity};
1629 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1630 $pkglist =~ s/^,+//;
1631 $pkglist =~ s/,+$//;
1632 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1633 $whendone = "done" if defined $data->{done} and length $data->{done};
1634 $severity = $data->{severity} if length $data->{severity};
1635 return sprintf "%s %d %d %s [%s] %s %s\n",
1636 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1637 $data->{originator}, $severity, $data->{keywords};
1642 =head1 PRIVATE FUNCTIONS
1646 sub update_realtime {
1647 my ($file, %bugs) = @_;
1649 # update realtime index.db
1651 return () unless keys %bugs;
1652 my $idx_old = IO::File->new($file,'r')
1653 or die "Couldn't open ${file}: $!";
1654 my $idx_new = IO::File->new($file.'.new','w')
1655 or die "Couldn't open ${file}.new: $!";
1657 binmode($idx_old,':raw:utf8');
1658 binmode($idx_new,':raw:encoding(UTF-8)');
1659 my $min_bug = min(keys %bugs);
1663 while($line = <$idx_old>) {
1664 @line = split /\s/, $line;
1665 # Two cases; replacing existing line or adding new line
1666 if (exists $bugs{$line[1]}) {
1667 my $new = $bugs{$line[1]};
1668 delete $bugs{$line[1]};
1669 $min_bug = min(keys %bugs);
1670 if ($new eq "NOCHANGE") {
1671 print {$idx_new} $line;
1672 $changed_bugs{$line[1]} = $line;
1673 } elsif ($new eq "REMOVE") {
1674 $changed_bugs{$line[1]} = $line;
1676 print {$idx_new} $new;
1677 $changed_bugs{$line[1]} = $line;
1681 while ($line[1] > $min_bug) {
1682 print {$idx_new} $bugs{$min_bug};
1683 delete $bugs{$min_bug};
1684 last unless keys %bugs;
1685 $min_bug = min(keys %bugs);
1687 print {$idx_new} $line;
1689 last unless keys %bugs;
1691 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1693 print {$idx_new} <$idx_old>;
1698 rename("$file.new", $file);
1700 return %changed_bugs;
1703 sub bughook_archive {
1705 filelock("$config{spool_dir}/debbugs.trace.lock");
1706 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1707 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1708 map{($_,'REMOVE')} @refs);
1709 update_realtime("$config{spool_dir}/index.archive.realtime",
1715 my ( $type, %bugs_temp ) = @_;
1716 filelock("$config{spool_dir}/debbugs.trace.lock");
1719 for my $bug (keys %bugs_temp) {
1720 my $data = $bugs_temp{$bug};
1721 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1723 $bugs{$bug} = generate_index_db_line($data,$bug);
1725 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);