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::AllUtils 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};
285 # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
286 # and not include this bug
287 if (defined $data{mergedwith} and
291 grep { $_ != $data{bug_num}}
293 split / /, $data{mergedwith}
299 =head2 split_status_fields
301 my @data = split_status_fields(@data);
303 Splits splittable status fields (like package, tags, blocks,
304 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
305 passed @data intact using dclone.
307 In scalar context, returns only the first element of @data.
311 our $ditch_empty = sub{
313 my $splitter = shift @t;
314 return grep {length $_} map {split $splitter} @t;
317 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
319 (package => \&splitpackages,
320 affects => \&splitpackages,
321 # Ideally we won't have to split source, but because some consumers of
322 # get_bug_status cannot handle arrayref, we will split it here.
323 source => \&splitpackages,
324 blocks => $ditch_empty_space,
325 blockedby => $ditch_empty_space,
326 # this isn't strictly correct, but we'll split both of them for
327 # the time being until we ditch all use of keywords everywhere
329 keywords => $ditch_empty_space,
330 tags => $ditch_empty_space,
331 found_versions => $ditch_empty_space,
332 fixed_versions => $ditch_empty_space,
333 mergedwith => $ditch_empty_space,
336 sub split_status_fields {
337 my @data = @{dclone(\@_)};
338 for my $data (@data) {
339 next if not defined $data;
340 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
341 not (ref($data) and ref($data) eq 'HASH');
342 for my $field (keys %{$data}) {
343 next unless defined $data->{$field};
344 if (exists $split_fields{$field}) {
345 next if ref($data->{$field});
347 if (ref($split_fields{$field}) eq 'CODE') {
348 @elements = &{$split_fields{$field}}($data->{$field});
350 elsif (not ref($split_fields{$field}) or
351 UNIVERSAL::isa($split_fields{$field},'Regex')
353 @elements = split $split_fields{$field}, $data->{$field};
355 $data->{$field} = \@elements;
359 return wantarray?@data:$data[0];
362 =head2 join_status_fields
364 my @data = join_status_fields(@data);
366 Handles joining the splitable status fields. (Basically, the inverse
367 of split_status_fields.
369 Primarily called from makestatus, but may be useful for other
370 functions after calling split_status_fields (or for legacy functions
371 if we transition to split fields by default).
375 sub join_status_fields {
382 found_versions => ' ',
383 fixed_versions => ' ',
388 my @data = @{dclone(\@_)};
389 for my $data (@data) {
390 next if not defined $data;
391 croak "Passed an element which is not a hashref to split_status_field: ".
393 if ref($data) ne 'HASH';
394 for my $field (keys %{$data}) {
395 next unless defined $data->{$field};
396 next unless ref($data->{$field}) eq 'ARRAY';
397 next unless exists $join_fields{$field};
398 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
401 return wantarray?@data:$data[0];
407 lockreadbug($bug_num,$location)
409 Performs a filelock, then reads the bug; the bug is unlocked if the
410 return is undefined, otherwise, you need to call unfilelock or
413 See readbug above for information on what this returns
418 my ($lref, $location) = @_;
419 return read_bug(bug => $lref, location => $location, lock => 1);
422 =head2 lockreadbugmerge
424 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
426 Performs a filelock, then reads the bug. If the bug is merged, locks
427 the merge lock. Returns a list of the number of locks and the bug
432 sub lockreadbugmerge {
433 my $data = lockreadbug(@_);
434 if (not defined $data) {
437 if (not length $data->{mergedwith}) {
441 filelock("$config{spool_dir}/lock/merge");
442 $data = lockreadbug(@_);
443 if (not defined $data) {
450 =head2 lock_read_all_merged_bugs
452 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
454 Performs a filelock, then reads the bug passed. If the bug is merged,
455 locks the merge lock, then reads and locks all of the other merged
456 bugs. Returns a list of the number of locks and the bug data for all
459 Will also return undef if any of the merged bugs failed to be read,
460 even if all of the others were read properly.
464 sub lock_read_all_merged_bugs {
465 my %param = validate_with(params => \@_,
466 spec => {bug => {type => SCALAR,
469 location => {type => SCALAR,
472 locks => {type => HASHREF,
478 my @data = read_bug(bug => $param{bug},
480 exists $param{location} ? (location => $param{location}):(),
481 exists $param{locks} ? (locks => $param{locks}):(),
483 if (not @data or not defined $data[0]) {
487 if (not length $data[0]->{mergedwith}) {
488 return ($locks,@data);
490 unfilelock(exists $param{locks}?$param{locks}:());
492 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
494 @data = read_bug(bug => $param{bug},
496 exists $param{location} ? (location => $param{location}):(),
497 exists $param{locks} ? (locks => $param{locks}):(),
499 if (not @data or not defined $data[0]) {
500 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
505 my @bugs = split / /, $data[0]->{mergedwith};
506 push @bugs, $param{bug};
507 for my $bug (@bugs) {
509 if ($bug != $param{bug}) {
511 read_bug(bug => $bug,
513 exists $param{location} ? (location => $param{location}):(),
514 exists $param{locks} ? (locks => $param{locks}):(),
516 if (not defined $newdata) {
518 unfilelock(exists $param{locks}?$param{locks}:());
521 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
526 # perform a sanity check to make sure that the merged bugs
527 # are all merged with eachother
528 # We do a cmp sort instead of an <=> sort here, because that's
531 join(' ',grep {$_ != $bug }
534 if ($newdata->{mergedwith} ne $expectmerge) {
536 unfilelock(exists $param{locks}?$param{locks}:());
538 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
542 return ($locks,@data);
547 my $new_bug_num = new_bug(copy => $data->{bug_num});
549 Creates a new bug and returns the new bug number upon success.
557 validate_with(params => \@_,
558 spec => {copy => {type => SCALAR,
564 filelock("nextnumber.lock");
565 my $nn_fh = IO::File->new("nextnumber",'r') or
566 die "Unable to open nextnuber for reading: $!";
569 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
571 overwritefile("nextnumber",
574 my $nn_hash = get_hashname($nn);
576 my $c_hash = get_hashname($param{copy});
577 for my $file (qw(log status summary report)) {
578 copy("db-h/$c_hash/$param{copy}.$file",
579 "db-h/$nn_hash/${nn}.$file")
583 for my $file (qw(log status summary report)) {
584 overwritefile("db-h/$nn_hash/${nn}.$file",
589 # this probably needs to be munged to do something more elegant
590 # &bughook('new', $clone, $data);
597 my @v1fieldorder = qw(originator date subject msgid package
598 keywords done forwarded mergedwith severity);
602 my $content = makestatus($status,$version)
603 my $content = makestatus($status);
605 Creates the content for a status file based on the $status hashref
608 Really only useful for writebug
610 Currently defaults to version 2 (non-encoded rfc1522 names) but will
611 eventually default to version 3. If you care, you should specify a
617 my ($data,$version) = @_;
618 $version = 3 unless defined $version;
622 my %newdata = %$data;
623 for my $field (qw(found fixed)) {
624 if (exists $newdata{$field}) {
625 $newdata{"${field}_date"} =
626 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
629 %newdata = %{join_status_fields(\%newdata)};
631 %newdata = encode_utf8_structure(%newdata);
634 for my $field (@rfc1522_fields) {
635 $newdata{$field} = encode_rfc1522($newdata{$field});
639 # this is a bit of a hack; we should never, ever have \r or \n in
640 # the fields of status. Kill them off here. [Eventually, this
641 # should be superfluous.]
642 for my $field (keys %newdata) {
643 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
647 for my $field (@v1fieldorder) {
648 if (exists $newdata{$field} and defined $newdata{$field}) {
649 $contents .= "$newdata{$field}\n";
654 } elsif ($version == 2 or $version == 3) {
655 # Version 2 or 3. Add a file format version number for the sake of
656 # further extensibility in the future.
657 $contents .= "Format-Version: $version\n";
658 for my $field (keys %fields) {
659 if (exists $newdata{$field} and defined $newdata{$field}
660 and $newdata{$field} ne '') {
661 # Output field names in proper case, e.g. 'Merged-With'.
662 my $properfield = $fields{$field};
663 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
664 my $data = $newdata{$field};
665 $contents .= "$properfield: $data\n";
674 writebug($bug_num,$status,$location,$minversion,$disablebughook)
676 Writes the bug status and summary files out.
678 Skips writing out a status file if minversion is 2
680 Does not call bughook if disablebughook is true.
685 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
688 my %outputs = (1 => 'status', 3 => 'summary');
689 for my $version (keys %outputs) {
690 next if defined $minversion and $version < $minversion;
691 my $status = getbugcomponent($ref, $outputs{$version}, $location);
692 die "can't find location for $ref" unless defined $status;
695 open $sfh,">","$status.new" or
696 die "opening $status.new: $!";
699 open $sfh,">","$status.new" or
700 die "opening $status.new: $!";
702 print {$sfh} makestatus($data, $version) or
703 die "writing $status.new: $!";
704 close($sfh) or die "closing $status.new: $!";
710 rename("$status.new",$status) || die "installing new $status: $!";
713 # $disablebughook is a bit of a hack to let format migration scripts use
714 # this function rather than having to duplicate it themselves.
715 &bughook($change,$ref,$data) unless $disablebughook;
718 =head2 unlockwritebug
720 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
722 Writes a bug, then calls unfilelock; see writebug for what these
734 The following functions are exported with the :versions tag
736 =head2 addfoundversions
738 addfoundversions($status,$package,$version,$isbinary);
740 All use of this should be phased out in favor of Debbugs::Control::fixed/found
745 sub addfoundversions {
749 my $isbinary = shift;
750 return unless defined $version;
751 undef $package if defined $package and $package =~ m[(?:\s|/)];
752 my $source = $package;
753 if (defined $package and $package =~ s/^src://) {
758 if (defined $package and $isbinary) {
759 my @srcinfo = binary_to_source(binary => $package,
760 version => $version);
762 # We know the source package(s). Use a fully-qualified version.
763 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
766 # Otherwise, an unqualified version will have to do.
770 # Strip off various kinds of brain-damage.
772 $version =~ s/ *\(.*\)//;
773 $version =~ s/ +[A-Za-z].*//;
775 foreach my $ver (split /[,\s]+/, $version) {
776 my $sver = defined($source) ? "$source/$ver" : '';
777 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
778 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
780 @{$data->{fixed_versions}} =
781 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
785 =head2 removefoundversions
787 removefoundversions($data,$package,$versiontoremove)
789 Removes found versions from $data
791 If a version is fully qualified (contains /) only versions matching
792 exactly are removed. Otherwise, all versions matching the version
795 Currently $package and $isbinary are entirely ignored, but accepted
796 for backwards compatibility.
800 sub removefoundversions {
804 my $isbinary = shift;
805 return unless defined $version;
807 foreach my $ver (split /[,\s]+/, $version) {
809 # fully qualified version
810 @{$data->{found_versions}} =
812 @{$data->{found_versions}};
815 # non qualified version; delete all matchers
816 @{$data->{found_versions}} =
817 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
818 @{$data->{found_versions}};
824 sub addfixedversions {
828 my $isbinary = shift;
829 return unless defined $version;
830 undef $package if defined $package and $package =~ m[(?:\s|/)];
831 my $source = $package;
833 if (defined $package and $isbinary) {
834 my @srcinfo = binary_to_source(binary => $package,
835 version => $version);
837 # We know the source package(s). Use a fully-qualified version.
838 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
841 # Otherwise, an unqualified version will have to do.
845 # Strip off various kinds of brain-damage.
847 $version =~ s/ *\(.*\)//;
848 $version =~ s/ +[A-Za-z].*//;
850 foreach my $ver (split /[,\s]+/, $version) {
851 my $sver = defined($source) ? "$source/$ver" : '';
852 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
853 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
855 @{$data->{found_versions}} =
856 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
860 sub removefixedversions {
864 my $isbinary = shift;
865 return unless defined $version;
867 foreach my $ver (split /[,\s]+/, $version) {
869 # fully qualified version
870 @{$data->{fixed_versions}} =
872 @{$data->{fixed_versions}};
875 # non qualified version; delete all matchers
876 @{$data->{fixed_versions}} =
877 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
878 @{$data->{fixed_versions}};
889 Split a package string from the status file into a list of package names.
895 return unless defined $pkgs;
896 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
900 =head2 bug_archiveable
902 bug_archiveable(bug => $bug_num);
908 =item bug -- bug number (required)
910 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
912 =item version -- Debbugs::Version information (optional)
914 =item days_until -- return days until the bug can be archived
918 Returns 1 if the bug can be archived
919 Returns 0 if the bug cannot be archived
921 If days_until is true, returns the number of days until the bug can be
922 archived, -1 if it cannot be archived. 0 means that the bug can be
923 archived the next time the archiver runs.
925 Returns undef on failure.
929 # This will eventually need to be fixed before we start using mod_perl
930 our $version_cache = {};
932 my %param = validate_with(params => \@_,
933 spec => {bug => {type => SCALAR,
936 status => {type => HASHREF,
939 days_until => {type => BOOLEAN,
942 ignore_time => {type => BOOLEAN,
947 # This is what we return if the bug cannot be archived.
948 my $cannot_archive = $param{days_until}?-1:0;
949 # read the status information
950 my $status = $param{status};
951 if (not exists $param{status} or not defined $status) {
952 $status = read_bug(bug=>$param{bug});
953 if (not defined $status) {
954 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
958 # Bugs can be archived if they are
960 if (not defined $status->{done} or not length $status->{done}) {
961 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
962 return $cannot_archive
964 # Check to make sure that the bug has none of the unremovable tags set
965 if (@{$config{removal_unremovable_tags}}) {
966 for my $tag (split ' ', ($status->{keywords}||'')) {
967 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
968 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
969 return $cannot_archive;
974 # If we just are checking if the bug can be archived, we'll not even bother
975 # checking the versioning information if the bug has been -done for less than 28 days.
976 my $log_file = getbugcomponent($param{bug},'log');
977 if (not defined $log_file) {
978 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
979 return $cannot_archive;
981 my $max_log_age = max(map {$config{remove_age} - -M $_}
982 $log_file, map {my $log = getbugcomponent($_,'log');
983 defined $log ? ($log) : ();
985 split / /, $status->{mergedwith}
987 if (not $param{days_until} and not $param{ignore_time}
990 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
991 return $cannot_archive;
993 # At this point, we have to get the versioning information for this bug.
994 # We examine the set of distribution tags. If a bug has no distribution
995 # tags set, we assume a default set, otherwise we use the tags the bug
998 # In cases where we are assuming a default set, if the severity
999 # is strong, we use the strong severity default; otherwise, we
1000 # use the normal default.
1002 # There must be fixed_versions for us to look at the versioning
1004 my $min_fixed_time = time;
1005 my $min_archive_days = 0;
1006 if (@{$status->{fixed_versions}}) {
1008 @dist_tags{@{$config{removal_distribution_tags}}} =
1009 (1) x @{$config{removal_distribution_tags}};
1011 for my $tag (split ' ', ($status->{keywords}||'')) {
1012 next unless exists $config{distribution_aliases}{$tag};
1013 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1014 $dists{$config{distribution_aliases}{$tag}} = 1;
1016 if (not keys %dists) {
1017 if (isstrongseverity($status->{severity})) {
1018 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1019 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1022 @dists{@{$config{removal_default_distribution_tags}}} =
1023 (1) x @{$config{removal_default_distribution_tags}};
1026 my %source_versions;
1027 my @sourceversions = get_versions(package => $status->{package},
1028 dist => [keys %dists],
1031 @source_versions{@sourceversions} = (1) x @sourceversions;
1032 # If the bug has not been fixed in the versions actually
1033 # distributed, then it cannot be archived.
1034 if ('found' eq max_buggy(bug => $param{bug},
1035 sourceversions => [keys %source_versions],
1036 found => $status->{found_versions},
1037 fixed => $status->{fixed_versions},
1038 version_cache => $version_cache,
1039 package => $status->{package},
1041 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1042 return $cannot_archive;
1044 # Since the bug has at least been fixed in the architectures
1045 # that matters, we check to see how long it has been fixed.
1047 # If $param{ignore_time}, then we should ignore time.
1048 if ($param{ignore_time}) {
1049 return $param{days_until}?0:1;
1052 # To do this, we order the times from most recent to oldest;
1053 # when we come to the first found version, we stop.
1054 # If we run out of versions, we only report the time of the
1056 my %time_versions = get_versions(package => $status->{package},
1057 dist => [keys %dists],
1061 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1062 my $buggy = buggy(bug => $param{bug},
1063 version => $version,
1064 found => $status->{found_versions},
1065 fixed => $status->{fixed_versions},
1066 version_cache => $version_cache,
1067 package => $status->{package},
1069 last if $buggy eq 'found';
1070 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1072 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1073 # if there are no versions in the archive at all, then
1074 # we can archive if enough days have passed
1077 # If $param{ignore_time}, then we should ignore time.
1078 if ($param{ignore_time}) {
1079 return $param{days_until}?0:1;
1081 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1082 my $age = ceil($max_log_age);
1083 if ($age > 0 or $min_archive_days > 0) {
1084 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1085 return $param{days_until}?max($age,$min_archive_days):0;
1088 return $param{days_until}?0:1;
1093 =head2 get_bug_status
1095 my $status = get_bug_status(bug => $nnn);
1097 my $status = get_bug_status($bug_num)
1103 =item bug -- scalar bug number
1105 =item status -- optional hashref of bug status as returned by readbug
1106 (can be passed to avoid rereading the bug information)
1108 =item bug_index -- optional tied index of bug status infomration;
1109 currently not correctly implemented.
1111 =item version -- optional version(s) to check package status at
1113 =item dist -- optional distribution(s) to check package status at
1115 =item arch -- optional architecture(s) to check package status at
1117 =item bugusertags -- optional hashref of bugusertags
1119 =item sourceversion -- optional arrayref of source/version; overrides
1120 dist, arch, and version. [The entries in this array must be in the
1121 "source/version" format.] Eventually this can be used to for caching.
1123 =item indicatesource -- if true, indicate which source packages this
1124 bug could belong to (or does belong to in the case of bugs assigned to
1125 a source package). Defaults to true.
1129 Note: Currently the version information is cached; this needs to be
1130 changed before using this function in long lived programs.
1134 Currently returns a hashref of status with the following keys.
1138 =item id -- bug number
1140 =item bug_num -- duplicate of id
1142 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1144 =item tags -- duplicate of keywords
1146 =item package -- name of package that the bug is assigned to
1148 =item severity -- severity of the bug
1150 =item pending -- pending state of the bug; one of following possible
1151 values; values listed later have precedence if multiple conditions are
1156 =item pending -- default state
1158 =item forwarded -- bug has been forwarded
1160 =item pending-fixed -- bug is tagged pending
1162 =item fixed -- bug is tagged fixed
1164 =item absent -- bug does not apply to this distribution/architecture
1166 =item done -- bug is resolved in this distribution/architecture
1170 =item location -- db-h or archive; the location in the filesystem
1172 =item subject -- title of the bug
1174 =item last_modified -- epoch that the bug was last modified
1176 =item date -- epoch that the bug was filed
1178 =item originator -- bug reporter
1180 =item log_modified -- epoch that the log file was last modified
1182 =item msgid -- Message id of the original bug report
1187 Other key/value pairs are returned but are not currently documented here.
1191 sub get_bug_status {
1195 my %param = validate_with(params => \@_,
1196 spec => {bug => {type => SCALAR,
1199 status => {type => HASHREF,
1202 bug_index => {type => OBJECT,
1205 version => {type => SCALAR|ARRAYREF,
1208 dist => {type => SCALAR|ARRAYREF,
1211 arch => {type => SCALAR|ARRAYREF,
1214 bugusertags => {type => HASHREF,
1217 sourceversions => {type => ARRAYREF,
1220 indicatesource => {type => BOOLEAN,
1227 if (defined $param{bug_index} and
1228 exists $param{bug_index}{$param{bug}}) {
1229 %status = %{ $param{bug_index}{$param{bug}} };
1230 $status{pending} = $status{ status };
1231 $status{id} = $param{bug};
1234 if (defined $param{status}) {
1235 %status = %{$param{status}};
1238 my $location = getbuglocation($param{bug}, 'summary');
1239 return {} if not defined $location or not length $location;
1240 %status = %{ readbug( $param{bug}, $location ) };
1242 $status{id} = $param{bug};
1244 if (defined $param{bugusertags}{$param{bug}}) {
1245 $status{keywords} = "" unless defined $status{keywords};
1246 $status{keywords} .= " " unless $status{keywords} eq "";
1247 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1249 $status{tags} = $status{keywords};
1250 my %tags = map { $_ => 1 } split ' ', $status{tags};
1252 $status{package} = '' if not defined $status{package};
1253 $status{"package"} =~ s/\s*$//;
1255 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1259 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1260 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1262 $status{"pending"} = 'pending';
1263 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1264 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1265 $status{"pending"} = 'fixed' if ($tags{fixed});
1268 my $presence = bug_presence(status => \%status,
1269 map{(exists $param{$_})?($_,$param{$_}):()}
1270 qw(bug sourceversions arch dist version found fixed package)
1272 if (defined $presence) {
1273 if ($presence eq 'fixed') {
1274 $status{pending} = 'done';
1276 elsif ($presence eq 'absent') {
1277 $status{pending} = 'absent';
1285 my $precence = bug_presence(bug => nnn,
1289 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1290 is found, absent, fixed, or no information is available in the
1291 distribution (dist) and/or architecture (arch) specified.
1298 =item bug -- scalar bug number
1300 =item status -- optional hashref of bug status as returned by readbug
1301 (can be passed to avoid rereading the bug information)
1303 =item bug_index -- optional tied index of bug status infomration;
1304 currently not correctly implemented.
1306 =item version -- optional version to check package status at
1308 =item dist -- optional distribution to check package status at
1310 =item arch -- optional architecture to check package status at
1312 =item sourceversion -- optional arrayref of source/version; overrides
1313 dist, arch, and version. [The entries in this array must be in the
1314 "source/version" format.] Eventually this can be used to for caching.
1321 my %param = validate_with(params => \@_,
1322 spec => {bug => {type => SCALAR,
1325 status => {type => HASHREF,
1328 version => {type => SCALAR|ARRAYREF,
1331 dist => {type => SCALAR|ARRAYREF,
1334 arch => {type => SCALAR|ARRAYREF,
1337 sourceversions => {type => ARRAYREF,
1343 if (defined $param{status}) {
1344 %status = %{$param{status}};
1347 my $location = getbuglocation($param{bug}, 'summary');
1348 return {} if not length $location;
1349 %status = %{ readbug( $param{bug}, $location ) };
1353 my $pseudo_desc = getpseudodesc();
1354 if (not exists $param{sourceversions}) {
1356 # pseudopackages do not have source versions by definition.
1357 if (exists $pseudo_desc->{$status{package}}) {
1360 elsif (defined $param{version}) {
1361 foreach my $arch (make_list($param{arch})) {
1362 for my $package (split /\s*,\s*/, $status{package}) {
1363 my @temp = makesourceversions($package,
1365 make_list($param{version})
1367 @sourceversions{@temp} = (1) x @temp;
1370 } elsif (defined $param{dist}) {
1371 my %affects_distribution_tags;
1372 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1373 (1) x @{$config{affects_distribution_tags}};
1374 my $some_distributions_disallowed = 0;
1375 my %allowed_distributions;
1376 for my $tag (split ' ', ($status{keywords}||'')) {
1377 if (exists $config{distribution_aliases}{$tag} and
1378 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1379 $some_distributions_disallowed = 1;
1380 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1382 elsif (exists $affects_distribution_tags{$tag}) {
1383 $some_distributions_disallowed = 1;
1384 $allowed_distributions{$tag} = 1;
1387 my @archs = make_list(exists $param{arch}?$param{arch}:());
1388 GET_SOURCE_VERSIONS:
1389 foreach my $arch (@archs) {
1390 for my $package (split /\s*,\s*/, $status{package}) {
1393 if ($package =~ /^src:(.+)$/) {
1397 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1398 # if some distributions are disallowed,
1399 # and this isn't an allowed
1400 # distribution, then we ignore this
1401 # distribution for the purposees of
1403 if ($some_distributions_disallowed and
1404 not exists $allowed_distributions{$dist}) {
1407 push @versions, get_versions(package => $package,
1409 ($source?(arch => 'source'):
1410 (defined $arch?(arch => $arch):())),
1413 next unless @versions;
1414 my @temp = make_source_versions(package => $package,
1416 versions => \@versions,
1418 @sourceversions{@temp} = (1) x @temp;
1421 # this should really be split out into a subroutine,
1422 # but it'd touch so many things currently, that we fake
1423 # it; it's needed to properly handle bugs which are
1424 # erroneously assigned to the binary package, and we'll
1425 # probably have it go away eventually.
1426 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1428 goto GET_SOURCE_VERSIONS;
1432 # TODO: This should probably be handled further out for efficiency and
1433 # for more ease of distinguishing between pkg= and src= queries.
1434 # DLA: src= queries should just pass arch=source, and they'll be happy.
1435 @sourceversions = keys %sourceversions;
1438 @sourceversions = @{$param{sourceversions}};
1440 my $maxbuggy = 'undef';
1441 if (@sourceversions) {
1442 $maxbuggy = max_buggy(bug => $param{bug},
1443 sourceversions => \@sourceversions,
1444 found => $status{found_versions},
1445 fixed => $status{fixed_versions},
1446 package => $status{package},
1447 version_cache => $version_cache,
1450 elsif (defined $param{dist} and
1451 not exists $pseudo_desc->{$status{package}}) {
1454 if (length($status{done}) and
1455 (not @sourceversions or not @{$status{fixed_versions}})) {
1470 =item bug -- scalar bug number
1472 =item sourceversion -- optional arrayref of source/version; overrides
1473 dist, arch, and version. [The entries in this array must be in the
1474 "source/version" format.] Eventually this can be used to for caching.
1478 Note: Currently the version information is cached; this needs to be
1479 changed before using this function in long lived programs.
1484 my %param = validate_with(params => \@_,
1485 spec => {bug => {type => SCALAR,
1488 sourceversions => {type => ARRAYREF,
1491 found => {type => ARRAYREF,
1494 fixed => {type => ARRAYREF,
1497 package => {type => SCALAR,
1499 version_cache => {type => HASHREF,
1504 # Resolve bugginess states (we might be looking at multiple
1505 # architectures, say). Found wins, then fixed, then absent.
1506 my $maxbuggy = 'absent';
1507 for my $package (split /\s*,\s*/, $param{package}) {
1508 for my $version (@{$param{sourceversions}}) {
1509 my $buggy = buggy(bug => $param{bug},
1510 version => $version,
1511 found => $param{found},
1512 fixed => $param{fixed},
1513 version_cache => $param{version_cache},
1514 package => $package,
1516 if ($buggy eq 'found') {
1518 } elsif ($buggy eq 'fixed') {
1519 $maxbuggy = 'fixed';
1536 Returns the output of Debbugs::Versions::buggy for a particular
1537 package, version and found/fixed set. Automatically turns found, fixed
1538 and version into source/version strings.
1540 Caching can be had by using the version_cache, but no attempt to check
1541 to see if the on disk information is more recent than the cache is
1542 made. [This will need to be fixed for long-lived processes.]
1547 my %param = validate_with(params => \@_,
1548 spec => {bug => {type => SCALAR,
1551 found => {type => ARRAYREF,
1554 fixed => {type => ARRAYREF,
1557 version_cache => {type => HASHREF,
1560 package => {type => SCALAR,
1562 version => {type => SCALAR,
1566 my @found = @{$param{found}};
1567 my @fixed = @{$param{fixed}};
1568 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1569 # We have non-source version versions
1570 @found = makesourceversions($param{package},undef,
1573 @fixed = makesourceversions($param{package},undef,
1577 if ($param{version} !~ m{/}) {
1578 my ($version) = makesourceversions($param{package},undef,
1581 $param{version} = $version if defined $version;
1583 # Figure out which source packages we need
1585 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1586 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1587 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1588 $param{version} =~ m{/};
1590 if (not defined $param{version_cache} or
1591 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1592 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1593 foreach my $source (keys %sources) {
1594 my $srchash = substr $source, 0, 1;
1595 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1596 if (not defined $version_fh) {
1597 # We only want to warn if it's a package which actually has a maintainer
1598 my $maints = getmaintainers();
1599 next if not exists $maints->{$source};
1600 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1603 $version->load($version_fh);
1605 if (defined $param{version_cache}) {
1606 $param{version_cache}{join(',',sort keys %sources)} = $version;
1610 $version = $param{version_cache}{join(',',sort keys %sources)};
1612 return $version->buggy($param{version},\@found,\@fixed);
1615 sub isstrongseverity {
1616 my $severity = shift;
1617 $severity = $config{default_severity} if
1618 not defined $severity or $severity eq '';
1619 return grep { $_ eq $severity } @{$config{strong_severities}};
1624 =head2 generate_index_db_line
1626 my $data = read_bug(bug => $bug,
1627 location => $initialdir);
1628 # generate_index_db_line hasn't been written yet at all.
1629 my $line = generate_index_db_line($data);
1631 Returns a line for a bug suitable to be written out to index.db.
1635 sub generate_index_db_line {
1636 my ($data,$bug) = @_;
1638 # just in case someone has given us a split out data
1639 $data = join_status_fields($data);
1641 my $whendone = "open";
1642 my $severity = $config{default_severity};
1643 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1644 $pkglist =~ s/^,+//;
1645 $pkglist =~ s/,+$//;
1646 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1647 $whendone = "done" if defined $data->{done} and length $data->{done};
1648 $severity = $data->{severity} if length $data->{severity};
1649 return sprintf "%s %d %d %s [%s] %s %s\n",
1650 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1651 $data->{originator}, $severity, $data->{keywords};
1656 =head1 PRIVATE FUNCTIONS
1660 sub update_realtime {
1661 my ($file, %bugs) = @_;
1663 # update realtime index.db
1665 return () unless keys %bugs;
1666 my $idx_old = IO::File->new($file,'r')
1667 or die "Couldn't open ${file}: $!";
1668 my $idx_new = IO::File->new($file.'.new','w')
1669 or die "Couldn't open ${file}.new: $!";
1671 binmode($idx_old,':raw:utf8');
1672 binmode($idx_new,':raw:encoding(UTF-8)');
1673 my $min_bug = min(keys %bugs);
1677 while($line = <$idx_old>) {
1678 @line = split /\s/, $line;
1679 # Two cases; replacing existing line or adding new line
1680 if (exists $bugs{$line[1]}) {
1681 my $new = $bugs{$line[1]};
1682 delete $bugs{$line[1]};
1683 $min_bug = min(keys %bugs);
1684 if ($new eq "NOCHANGE") {
1685 print {$idx_new} $line;
1686 $changed_bugs{$line[1]} = $line;
1687 } elsif ($new eq "REMOVE") {
1688 $changed_bugs{$line[1]} = $line;
1690 print {$idx_new} $new;
1691 $changed_bugs{$line[1]} = $line;
1695 while ($line[1] > $min_bug) {
1696 print {$idx_new} $bugs{$min_bug};
1697 delete $bugs{$min_bug};
1698 last unless keys %bugs;
1699 $min_bug = min(keys %bugs);
1701 print {$idx_new} $line;
1703 last unless keys %bugs;
1705 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1707 print {$idx_new} <$idx_old>;
1712 rename("$file.new", $file);
1714 return %changed_bugs;
1717 sub bughook_archive {
1719 filelock("$config{spool_dir}/debbugs.trace.lock");
1720 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1721 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1722 map{($_,'REMOVE')} @refs);
1723 update_realtime("$config{spool_dir}/index.archive.realtime",
1729 my ( $type, %bugs_temp ) = @_;
1730 filelock("$config{spool_dir}/debbugs.trace.lock");
1733 for my $bug (keys %bugs_temp) {
1734 my $data = $bugs_temp{$bug};
1735 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1737 $bugs{$bug} = generate_index_db_line($data,$bug);
1739 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);