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};
195 if (not defined $param{summary}) {
197 ($lref,$location) = @param{qw(bug location)};
198 if (not defined $location) {
199 $location = getbuglocation($lref,'summary');
200 return undef if not defined $location;
202 $status = getbugcomponent($lref, 'summary', $location);
203 $log = getbugcomponent($lref, 'log' , $location);
204 $report = getbugcomponent($lref, 'report' , $location);
205 return undef unless defined $status;
206 return undef if not -e $status;
209 $status = $param{summary};
212 $log =~ s/\.summary$/.log/;
213 $report =~ s/\.summary$/.report/;
214 ($location) = $status =~ m/(db-h|db|archive)/;
215 ($param{bug}) = $status =~ m/(\d+)\.summary$/;
218 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
220 my $status_fh = IO::File->new($status, 'r');
221 if (not defined $status_fh) {
222 warn "Unable to open $status for reading: $!";
224 unfilelock(exists $param{locks}?$param{locks}:());
228 binmode($status_fh,':encoding(UTF-8)');
235 while (<$status_fh>) {
238 $version = $1 if /^Format-Version: ([0-9]+)/i;
241 # Version 3 is the latest format version currently supported.
243 warn "Unsupported status version '$version'";
245 unfilelock(exists $param{locks}?$param{locks}:());
250 my %namemap = reverse %fields;
251 for my $line (@lines) {
252 if ($line =~ /(\S+?): (.*)/) {
253 my ($name, $value) = (lc $1, $2);
254 # this is a bit of a hack; we should never, ever have \r
255 # or \n in the fields of status. Kill them off here.
256 # [Eventually, this should be superfluous.]
257 $value =~ s/[\r\n]//g;
258 $data{$namemap{$name}} = $value if exists $namemap{$name};
261 for my $field (keys %fields) {
262 $data{$field} = '' unless exists $data{$field};
265 for my $field (@rfc1522_fields) {
266 $data{$field} = decode_rfc1522($data{$field});
269 $data{severity} = $config{default_severity} if $data{severity} eq '';
270 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
271 $data{$field} = [split ' ', $data{$field}];
273 for my $field (qw(found fixed)) {
274 # create the found/fixed hashes which indicate when a
275 # particular version was marked found or marked fixed.
276 @{$data{$field}}{@{$data{"${field}_versions"}}} =
277 (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}),
278 @{$data{"${field}_date"}});
281 my $status_modified = (stat($status))[9];
282 # Add log last modified time
283 $data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9];
284 my $report_modified = (stat($report))[9] // $data{log_modified};
285 $data{last_modified} = max($status_modified,$data{log_modified});
286 # if the date isn't set (ancient bug), use the smallest of any of the modified
287 if (not defined $data{date} or not length($data{date})) {
288 $data{date} = min($report_modified,$status_modified,$data{log_modified});
290 $data{location} = $location;
291 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
292 $data{bug_num} = $param{bug};
294 # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
295 # and not include this bug
296 if (defined $data{mergedwith} and
300 grep { $_ != $data{bug_num}}
302 split / /, $data{mergedwith}
308 =head2 split_status_fields
310 my @data = split_status_fields(@data);
312 Splits splittable status fields (like package, tags, blocks,
313 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
314 passed @data intact using dclone.
316 In scalar context, returns only the first element of @data.
320 our $ditch_empty = sub{
322 my $splitter = shift @t;
323 return grep {length $_} map {split $splitter} @t;
326 our $sort_and_unique = sub {
331 if ($all_numeric and $v =~ /\D/) {
334 next if exists $u{$v};
339 return sort {$a <=> $b} @v;
345 my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))};
347 (package => \&splitpackages,
348 affects => \&splitpackages,
349 # Ideally we won't have to split source, but because some consumers of
350 # get_bug_status cannot handle arrayref, we will split it here.
351 source => \&splitpackages,
352 blocks => $ditch_space_unique_and_sort,
353 blockedby => $ditch_space_unique_and_sort,
354 # this isn't strictly correct, but we'll split both of them for
355 # the time being until we ditch all use of keywords everywhere
357 keywords => $ditch_space_unique_and_sort,
358 tags => $ditch_space_unique_and_sort,
359 found_versions => $ditch_space_unique_and_sort,
360 fixed_versions => $ditch_space_unique_and_sort,
361 mergedwith => $ditch_space_unique_and_sort,
364 sub split_status_fields {
365 my @data = @{dclone(\@_)};
366 for my $data (@data) {
367 next if not defined $data;
368 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
369 not (ref($data) and ref($data) eq 'HASH');
370 for my $field (keys %{$data}) {
371 next unless defined $data->{$field};
372 if (exists $split_fields{$field}) {
373 next if ref($data->{$field});
375 if (ref($split_fields{$field}) eq 'CODE') {
376 @elements = &{$split_fields{$field}}($data->{$field});
378 elsif (not ref($split_fields{$field}) or
379 UNIVERSAL::isa($split_fields{$field},'Regex')
381 @elements = split $split_fields{$field}, $data->{$field};
383 $data->{$field} = \@elements;
387 return wantarray?@data:$data[0];
390 =head2 join_status_fields
392 my @data = join_status_fields(@data);
394 Handles joining the splitable status fields. (Basically, the inverse
395 of split_status_fields.
397 Primarily called from makestatus, but may be useful for other
398 functions after calling split_status_fields (or for legacy functions
399 if we transition to split fields by default).
403 sub join_status_fields {
410 found_versions => ' ',
411 fixed_versions => ' ',
416 my @data = @{dclone(\@_)};
417 for my $data (@data) {
418 next if not defined $data;
419 croak "Passed an element which is not a hashref to split_status_field: ".
421 if ref($data) ne 'HASH';
422 for my $field (keys %{$data}) {
423 next unless defined $data->{$field};
424 next unless ref($data->{$field}) eq 'ARRAY';
425 next unless exists $join_fields{$field};
426 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
429 return wantarray?@data:$data[0];
435 lockreadbug($bug_num,$location)
437 Performs a filelock, then reads the bug; the bug is unlocked if the
438 return is undefined, otherwise, you need to call unfilelock or
441 See readbug above for information on what this returns
446 my ($lref, $location) = @_;
447 return read_bug(bug => $lref, location => $location, lock => 1);
450 =head2 lockreadbugmerge
452 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
454 Performs a filelock, then reads the bug. If the bug is merged, locks
455 the merge lock. Returns a list of the number of locks and the bug
460 sub lockreadbugmerge {
461 my $data = lockreadbug(@_);
462 if (not defined $data) {
465 if (not length $data->{mergedwith}) {
469 filelock("$config{spool_dir}/lock/merge");
470 $data = lockreadbug(@_);
471 if (not defined $data) {
478 =head2 lock_read_all_merged_bugs
480 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
482 Performs a filelock, then reads the bug passed. If the bug is merged,
483 locks the merge lock, then reads and locks all of the other merged
484 bugs. Returns a list of the number of locks and the bug data for all
487 Will also return undef if any of the merged bugs failed to be read,
488 even if all of the others were read properly.
492 sub lock_read_all_merged_bugs {
493 my %param = validate_with(params => \@_,
494 spec => {bug => {type => SCALAR,
497 location => {type => SCALAR,
500 locks => {type => HASHREF,
506 my @data = read_bug(bug => $param{bug},
508 exists $param{location} ? (location => $param{location}):(),
509 exists $param{locks} ? (locks => $param{locks}):(),
511 if (not @data or not defined $data[0]) {
515 if (not length $data[0]->{mergedwith}) {
516 return ($locks,@data);
518 unfilelock(exists $param{locks}?$param{locks}:());
520 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
522 @data = read_bug(bug => $param{bug},
524 exists $param{location} ? (location => $param{location}):(),
525 exists $param{locks} ? (locks => $param{locks}):(),
527 if (not @data or not defined $data[0]) {
528 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
533 my @bugs = split / /, $data[0]->{mergedwith};
534 push @bugs, $param{bug};
535 for my $bug (@bugs) {
537 if ($bug != $param{bug}) {
539 read_bug(bug => $bug,
541 exists $param{location} ? (location => $param{location}):(),
542 exists $param{locks} ? (locks => $param{locks}):(),
544 if (not defined $newdata) {
546 unfilelock(exists $param{locks}?$param{locks}:());
549 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
554 # perform a sanity check to make sure that the merged bugs
555 # are all merged with eachother
556 # We do a cmp sort instead of an <=> sort here, because that's
559 join(' ',grep {$_ != $bug }
562 if ($newdata->{mergedwith} ne $expectmerge) {
564 unfilelock(exists $param{locks}?$param{locks}:());
566 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
570 return ($locks,@data);
575 my $new_bug_num = new_bug(copy => $data->{bug_num});
577 Creates a new bug and returns the new bug number upon success.
585 validate_with(params => \@_,
586 spec => {copy => {type => SCALAR,
592 filelock("nextnumber.lock");
593 my $nn_fh = IO::File->new("nextnumber",'r') or
594 die "Unable to open nextnuber for reading: $!";
597 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
599 overwritefile("nextnumber",
602 my $nn_hash = get_hashname($nn);
604 my $c_hash = get_hashname($param{copy});
605 for my $file (qw(log status summary report)) {
606 copy("db-h/$c_hash/$param{copy}.$file",
607 "db-h/$nn_hash/${nn}.$file")
611 for my $file (qw(log status summary report)) {
612 overwritefile("db-h/$nn_hash/${nn}.$file",
617 # this probably needs to be munged to do something more elegant
618 # &bughook('new', $clone, $data);
625 my @v1fieldorder = qw(originator date subject msgid package
626 keywords done forwarded mergedwith severity);
630 my $content = makestatus($status,$version)
631 my $content = makestatus($status);
633 Creates the content for a status file based on the $status hashref
636 Really only useful for writebug
638 Currently defaults to version 2 (non-encoded rfc1522 names) but will
639 eventually default to version 3. If you care, you should specify a
645 my ($data,$version) = @_;
646 $version = 3 unless defined $version;
650 my %newdata = %$data;
651 for my $field (qw(found fixed)) {
652 if (exists $newdata{$field}) {
653 $newdata{"${field}_date"} =
654 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
657 %newdata = %{join_status_fields(\%newdata)};
659 %newdata = encode_utf8_structure(%newdata);
662 for my $field (@rfc1522_fields) {
663 $newdata{$field} = encode_rfc1522($newdata{$field});
667 # this is a bit of a hack; we should never, ever have \r or \n in
668 # the fields of status. Kill them off here. [Eventually, this
669 # should be superfluous.]
670 for my $field (keys %newdata) {
671 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
675 for my $field (@v1fieldorder) {
676 if (exists $newdata{$field} and defined $newdata{$field}) {
677 $contents .= "$newdata{$field}\n";
682 } elsif ($version == 2 or $version == 3) {
683 # Version 2 or 3. Add a file format version number for the sake of
684 # further extensibility in the future.
685 $contents .= "Format-Version: $version\n";
686 for my $field (keys %fields) {
687 if (exists $newdata{$field} and defined $newdata{$field}
688 and $newdata{$field} ne '') {
689 # Output field names in proper case, e.g. 'Merged-With'.
690 my $properfield = $fields{$field};
691 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
692 my $data = $newdata{$field};
693 $contents .= "$properfield: $data\n";
702 writebug($bug_num,$status,$location,$minversion,$disablebughook)
704 Writes the bug status and summary files out.
706 Skips writing out a status file if minversion is 2
708 Does not call bughook if disablebughook is true.
713 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
716 my %outputs = (1 => 'status', 3 => 'summary');
717 for my $version (keys %outputs) {
718 next if defined $minversion and $version < $minversion;
719 my $status = getbugcomponent($ref, $outputs{$version}, $location);
720 die "can't find location for $ref" unless defined $status;
723 open $sfh,">","$status.new" or
724 die "opening $status.new: $!";
727 open $sfh,">","$status.new" or
728 die "opening $status.new: $!";
730 print {$sfh} makestatus($data, $version) or
731 die "writing $status.new: $!";
732 close($sfh) or die "closing $status.new: $!";
738 rename("$status.new",$status) || die "installing new $status: $!";
741 # $disablebughook is a bit of a hack to let format migration scripts use
742 # this function rather than having to duplicate it themselves.
743 &bughook($change,$ref,$data) unless $disablebughook;
746 =head2 unlockwritebug
748 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
750 Writes a bug, then calls unfilelock; see writebug for what these
762 The following functions are exported with the :versions tag
764 =head2 addfoundversions
766 addfoundversions($status,$package,$version,$isbinary);
768 All use of this should be phased out in favor of Debbugs::Control::fixed/found
773 sub addfoundversions {
777 my $isbinary = shift;
778 return unless defined $version;
779 undef $package if defined $package and $package =~ m[(?:\s|/)];
780 my $source = $package;
781 if (defined $package and $package =~ s/^src://) {
786 if (defined $package and $isbinary) {
787 my @srcinfo = binary_to_source(binary => $package,
788 version => $version);
790 # We know the source package(s). Use a fully-qualified version.
791 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
794 # Otherwise, an unqualified version will have to do.
798 # Strip off various kinds of brain-damage.
800 $version =~ s/ *\(.*\)//;
801 $version =~ s/ +[A-Za-z].*//;
803 foreach my $ver (split /[,\s]+/, $version) {
804 my $sver = defined($source) ? "$source/$ver" : '';
805 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
806 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
808 @{$data->{fixed_versions}} =
809 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
813 =head2 removefoundversions
815 removefoundversions($data,$package,$versiontoremove)
817 Removes found versions from $data
819 If a version is fully qualified (contains /) only versions matching
820 exactly are removed. Otherwise, all versions matching the version
823 Currently $package and $isbinary are entirely ignored, but accepted
824 for backwards compatibility.
828 sub removefoundversions {
832 my $isbinary = shift;
833 return unless defined $version;
835 foreach my $ver (split /[,\s]+/, $version) {
837 # fully qualified version
838 @{$data->{found_versions}} =
840 @{$data->{found_versions}};
843 # non qualified version; delete all matchers
844 @{$data->{found_versions}} =
845 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
846 @{$data->{found_versions}};
852 sub addfixedversions {
856 my $isbinary = shift;
857 return unless defined $version;
858 undef $package if defined $package and $package =~ m[(?:\s|/)];
859 my $source = $package;
861 if (defined $package and $isbinary) {
862 my @srcinfo = binary_to_source(binary => $package,
863 version => $version);
865 # We know the source package(s). Use a fully-qualified version.
866 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
869 # Otherwise, an unqualified version will have to do.
873 # Strip off various kinds of brain-damage.
875 $version =~ s/ *\(.*\)//;
876 $version =~ s/ +[A-Za-z].*//;
878 foreach my $ver (split /[,\s]+/, $version) {
879 my $sver = defined($source) ? "$source/$ver" : '';
880 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
881 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
883 @{$data->{found_versions}} =
884 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
888 sub removefixedversions {
892 my $isbinary = shift;
893 return unless defined $version;
895 foreach my $ver (split /[,\s]+/, $version) {
897 # fully qualified version
898 @{$data->{fixed_versions}} =
900 @{$data->{fixed_versions}};
903 # non qualified version; delete all matchers
904 @{$data->{fixed_versions}} =
905 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
906 @{$data->{fixed_versions}};
917 Split a package string from the status file into a list of package names.
923 return unless defined $pkgs;
924 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
928 =head2 bug_archiveable
930 bug_archiveable(bug => $bug_num);
936 =item bug -- bug number (required)
938 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
940 =item version -- Debbugs::Version information (optional)
942 =item days_until -- return days until the bug can be archived
946 Returns 1 if the bug can be archived
947 Returns 0 if the bug cannot be archived
949 If days_until is true, returns the number of days until the bug can be
950 archived, -1 if it cannot be archived. 0 means that the bug can be
951 archived the next time the archiver runs.
953 Returns undef on failure.
957 # This will eventually need to be fixed before we start using mod_perl
958 our $version_cache = {};
960 my %param = validate_with(params => \@_,
961 spec => {bug => {type => SCALAR,
964 status => {type => HASHREF,
967 days_until => {type => BOOLEAN,
970 ignore_time => {type => BOOLEAN,
975 # This is what we return if the bug cannot be archived.
976 my $cannot_archive = $param{days_until}?-1:0;
977 # read the status information
978 my $status = $param{status};
979 if (not exists $param{status} or not defined $status) {
980 $status = read_bug(bug=>$param{bug});
981 if (not defined $status) {
982 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
986 # Bugs can be archived if they are
988 if (not defined $status->{done} or not length $status->{done}) {
989 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
990 return $cannot_archive
992 # Check to make sure that the bug has none of the unremovable tags set
993 if (@{$config{removal_unremovable_tags}}) {
994 for my $tag (split ' ', ($status->{keywords}||'')) {
995 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
996 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
997 return $cannot_archive;
1002 # If we just are checking if the bug can be archived, we'll not even bother
1003 # checking the versioning information if the bug has been -done for less than 28 days.
1004 my $log_file = getbugcomponent($param{bug},'log');
1005 if (not defined $log_file) {
1006 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
1007 return $cannot_archive;
1009 my $max_log_age = max(map {$config{remove_age} - -M $_}
1010 $log_file, map {my $log = getbugcomponent($_,'log');
1011 defined $log ? ($log) : ();
1013 split / /, $status->{mergedwith}
1015 if (not $param{days_until} and not $param{ignore_time}
1016 and $max_log_age > 0
1018 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
1019 return $cannot_archive;
1021 # At this point, we have to get the versioning information for this bug.
1022 # We examine the set of distribution tags. If a bug has no distribution
1023 # tags set, we assume a default set, otherwise we use the tags the bug
1026 # In cases where we are assuming a default set, if the severity
1027 # is strong, we use the strong severity default; otherwise, we
1028 # use the normal default.
1030 # There must be fixed_versions for us to look at the versioning
1032 my $min_fixed_time = time;
1033 my $min_archive_days = 0;
1034 if (@{$status->{fixed_versions}}) {
1036 @dist_tags{@{$config{removal_distribution_tags}}} =
1037 (1) x @{$config{removal_distribution_tags}};
1039 for my $tag (split ' ', ($status->{keywords}||'')) {
1040 next unless exists $config{distribution_aliases}{$tag};
1041 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1042 $dists{$config{distribution_aliases}{$tag}} = 1;
1044 if (not keys %dists) {
1045 if (isstrongseverity($status->{severity})) {
1046 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1047 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1050 @dists{@{$config{removal_default_distribution_tags}}} =
1051 (1) x @{$config{removal_default_distribution_tags}};
1054 my %source_versions;
1055 my @sourceversions = get_versions(package => $status->{package},
1056 dist => [keys %dists],
1059 @source_versions{@sourceversions} = (1) x @sourceversions;
1060 # If the bug has not been fixed in the versions actually
1061 # distributed, then it cannot be archived.
1062 if ('found' eq max_buggy(bug => $param{bug},
1063 sourceversions => [keys %source_versions],
1064 found => $status->{found_versions},
1065 fixed => $status->{fixed_versions},
1066 version_cache => $version_cache,
1067 package => $status->{package},
1069 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1070 return $cannot_archive;
1072 # Since the bug has at least been fixed in the architectures
1073 # that matters, we check to see how long it has been fixed.
1075 # If $param{ignore_time}, then we should ignore time.
1076 if ($param{ignore_time}) {
1077 return $param{days_until}?0:1;
1080 # To do this, we order the times from most recent to oldest;
1081 # when we come to the first found version, we stop.
1082 # If we run out of versions, we only report the time of the
1084 my %time_versions = get_versions(package => $status->{package},
1085 dist => [keys %dists],
1089 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1090 my $buggy = buggy(bug => $param{bug},
1091 version => $version,
1092 found => $status->{found_versions},
1093 fixed => $status->{fixed_versions},
1094 version_cache => $version_cache,
1095 package => $status->{package},
1097 last if $buggy eq 'found';
1098 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1100 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1101 # if there are no versions in the archive at all, then
1102 # we can archive if enough days have passed
1105 # If $param{ignore_time}, then we should ignore time.
1106 if ($param{ignore_time}) {
1107 return $param{days_until}?0:1;
1109 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1110 my $age = ceil($max_log_age);
1111 if ($age > 0 or $min_archive_days > 0) {
1112 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1113 return $param{days_until}?max($age,$min_archive_days):0;
1116 return $param{days_until}?0:1;
1121 =head2 get_bug_status
1123 my $status = get_bug_status(bug => $nnn);
1125 my $status = get_bug_status($bug_num)
1131 =item bug -- scalar bug number
1133 =item status -- optional hashref of bug status as returned by readbug
1134 (can be passed to avoid rereading the bug information)
1136 =item bug_index -- optional tied index of bug status infomration;
1137 currently not correctly implemented.
1139 =item version -- optional version(s) to check package status at
1141 =item dist -- optional distribution(s) to check package status at
1143 =item arch -- optional architecture(s) to check package status at
1145 =item bugusertags -- optional hashref of bugusertags
1147 =item sourceversion -- optional arrayref of source/version; overrides
1148 dist, arch, and version. [The entries in this array must be in the
1149 "source/version" format.] Eventually this can be used to for caching.
1151 =item indicatesource -- if true, indicate which source packages this
1152 bug could belong to (or does belong to in the case of bugs assigned to
1153 a source package). Defaults to true.
1157 Note: Currently the version information is cached; this needs to be
1158 changed before using this function in long lived programs.
1162 Currently returns a hashref of status with the following keys.
1166 =item id -- bug number
1168 =item bug_num -- duplicate of id
1170 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1172 =item tags -- duplicate of keywords
1174 =item package -- name of package that the bug is assigned to
1176 =item severity -- severity of the bug
1178 =item pending -- pending state of the bug; one of following possible
1179 values; values listed later have precedence if multiple conditions are
1184 =item pending -- default state
1186 =item forwarded -- bug has been forwarded
1188 =item pending-fixed -- bug is tagged pending
1190 =item fixed -- bug is tagged fixed
1192 =item absent -- bug does not apply to this distribution/architecture
1194 =item done -- bug is resolved in this distribution/architecture
1198 =item location -- db-h or archive; the location in the filesystem
1200 =item subject -- title of the bug
1202 =item last_modified -- epoch that the bug was last modified
1204 =item date -- epoch that the bug was filed
1206 =item originator -- bug reporter
1208 =item log_modified -- epoch that the log file was last modified
1210 =item msgid -- Message id of the original bug report
1215 Other key/value pairs are returned but are not currently documented here.
1219 sub get_bug_status {
1223 my %param = validate_with(params => \@_,
1224 spec => {bug => {type => SCALAR,
1227 status => {type => HASHREF,
1230 bug_index => {type => OBJECT,
1233 version => {type => SCALAR|ARRAYREF,
1236 dist => {type => SCALAR|ARRAYREF,
1239 arch => {type => SCALAR|ARRAYREF,
1242 bugusertags => {type => HASHREF,
1245 sourceversions => {type => ARRAYREF,
1248 indicatesource => {type => BOOLEAN,
1255 if (defined $param{bug_index} and
1256 exists $param{bug_index}{$param{bug}}) {
1257 %status = %{ $param{bug_index}{$param{bug}} };
1258 $status{pending} = $status{ status };
1259 $status{id} = $param{bug};
1262 if (defined $param{status}) {
1263 %status = %{$param{status}};
1266 my $location = getbuglocation($param{bug}, 'summary');
1267 return {} if not defined $location or not length $location;
1268 %status = %{ readbug( $param{bug}, $location ) };
1270 $status{id} = $param{bug};
1272 if (defined $param{bugusertags}{$param{bug}}) {
1273 $status{keywords} = "" unless defined $status{keywords};
1274 $status{keywords} .= " " unless $status{keywords} eq "";
1275 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1277 $status{tags} = $status{keywords};
1278 my %tags = map { $_ => 1 } split ' ', $status{tags};
1280 $status{package} = '' if not defined $status{package};
1281 $status{"package"} =~ s/\s*$//;
1283 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1287 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1288 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1290 $status{"pending"} = 'pending';
1291 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1292 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1293 $status{"pending"} = 'fixed' if ($tags{fixed});
1296 my $presence = bug_presence(status => \%status,
1297 map{(exists $param{$_})?($_,$param{$_}):()}
1298 qw(bug sourceversions arch dist version found fixed package)
1300 if (defined $presence) {
1301 if ($presence eq 'fixed') {
1302 $status{pending} = 'done';
1304 elsif ($presence eq 'absent') {
1305 $status{pending} = 'absent';
1313 my $precence = bug_presence(bug => nnn,
1317 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1318 is found, absent, fixed, or no information is available in the
1319 distribution (dist) and/or architecture (arch) specified.
1326 =item bug -- scalar bug number
1328 =item status -- optional hashref of bug status as returned by readbug
1329 (can be passed to avoid rereading the bug information)
1331 =item bug_index -- optional tied index of bug status infomration;
1332 currently not correctly implemented.
1334 =item version -- optional version to check package status at
1336 =item dist -- optional distribution to check package status at
1338 =item arch -- optional architecture to check package status at
1340 =item sourceversion -- optional arrayref of source/version; overrides
1341 dist, arch, and version. [The entries in this array must be in the
1342 "source/version" format.] Eventually this can be used to for caching.
1349 my %param = validate_with(params => \@_,
1350 spec => {bug => {type => SCALAR,
1353 status => {type => HASHREF,
1356 version => {type => SCALAR|ARRAYREF,
1359 dist => {type => SCALAR|ARRAYREF,
1362 arch => {type => SCALAR|ARRAYREF,
1365 sourceversions => {type => ARRAYREF,
1371 if (defined $param{status}) {
1372 %status = %{$param{status}};
1375 my $location = getbuglocation($param{bug}, 'summary');
1376 return {} if not length $location;
1377 %status = %{ readbug( $param{bug}, $location ) };
1381 my $pseudo_desc = getpseudodesc();
1382 if (not exists $param{sourceversions}) {
1384 # pseudopackages do not have source versions by definition.
1385 if (exists $pseudo_desc->{$status{package}}) {
1388 elsif (defined $param{version}) {
1389 foreach my $arch (make_list($param{arch})) {
1390 for my $package (split /\s*,\s*/, $status{package}) {
1391 my @temp = makesourceversions($package,
1393 make_list($param{version})
1395 @sourceversions{@temp} = (1) x @temp;
1398 } elsif (defined $param{dist}) {
1399 my %affects_distribution_tags;
1400 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1401 (1) x @{$config{affects_distribution_tags}};
1402 my $some_distributions_disallowed = 0;
1403 my %allowed_distributions;
1404 for my $tag (split ' ', ($status{keywords}||'')) {
1405 if (exists $config{distribution_aliases}{$tag} and
1406 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1407 $some_distributions_disallowed = 1;
1408 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1410 elsif (exists $affects_distribution_tags{$tag}) {
1411 $some_distributions_disallowed = 1;
1412 $allowed_distributions{$tag} = 1;
1415 my @archs = make_list(exists $param{arch}?$param{arch}:());
1416 GET_SOURCE_VERSIONS:
1417 foreach my $arch (@archs) {
1418 for my $package (split /\s*,\s*/, $status{package}) {
1421 if ($package =~ /^src:(.+)$/) {
1425 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1426 # if some distributions are disallowed,
1427 # and this isn't an allowed
1428 # distribution, then we ignore this
1429 # distribution for the purposees of
1431 if ($some_distributions_disallowed and
1432 not exists $allowed_distributions{$dist}) {
1435 push @versions, get_versions(package => $package,
1437 ($source?(arch => 'source'):
1438 (defined $arch?(arch => $arch):())),
1441 next unless @versions;
1442 my @temp = make_source_versions(package => $package,
1444 versions => \@versions,
1446 @sourceversions{@temp} = (1) x @temp;
1449 # this should really be split out into a subroutine,
1450 # but it'd touch so many things currently, that we fake
1451 # it; it's needed to properly handle bugs which are
1452 # erroneously assigned to the binary package, and we'll
1453 # probably have it go away eventually.
1454 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1456 goto GET_SOURCE_VERSIONS;
1460 # TODO: This should probably be handled further out for efficiency and
1461 # for more ease of distinguishing between pkg= and src= queries.
1462 # DLA: src= queries should just pass arch=source, and they'll be happy.
1463 @sourceversions = keys %sourceversions;
1466 @sourceversions = @{$param{sourceversions}};
1468 my $maxbuggy = 'undef';
1469 if (@sourceversions) {
1470 $maxbuggy = max_buggy(bug => $param{bug},
1471 sourceversions => \@sourceversions,
1472 found => $status{found_versions},
1473 fixed => $status{fixed_versions},
1474 package => $status{package},
1475 version_cache => $version_cache,
1478 elsif (defined $param{dist} and
1479 not exists $pseudo_desc->{$status{package}}) {
1482 if (length($status{done}) and
1483 (not @sourceversions or not @{$status{fixed_versions}})) {
1498 =item bug -- scalar bug number
1500 =item sourceversion -- optional arrayref of source/version; overrides
1501 dist, arch, and version. [The entries in this array must be in the
1502 "source/version" format.] Eventually this can be used to for caching.
1506 Note: Currently the version information is cached; this needs to be
1507 changed before using this function in long lived programs.
1512 my %param = validate_with(params => \@_,
1513 spec => {bug => {type => SCALAR,
1516 sourceversions => {type => ARRAYREF,
1519 found => {type => ARRAYREF,
1522 fixed => {type => ARRAYREF,
1525 package => {type => SCALAR,
1527 version_cache => {type => HASHREF,
1532 # Resolve bugginess states (we might be looking at multiple
1533 # architectures, say). Found wins, then fixed, then absent.
1534 my $maxbuggy = 'absent';
1535 for my $package (split /\s*,\s*/, $param{package}) {
1536 for my $version (@{$param{sourceversions}}) {
1537 my $buggy = buggy(bug => $param{bug},
1538 version => $version,
1539 found => $param{found},
1540 fixed => $param{fixed},
1541 version_cache => $param{version_cache},
1542 package => $package,
1544 if ($buggy eq 'found') {
1546 } elsif ($buggy eq 'fixed') {
1547 $maxbuggy = 'fixed';
1564 Returns the output of Debbugs::Versions::buggy for a particular
1565 package, version and found/fixed set. Automatically turns found, fixed
1566 and version into source/version strings.
1568 Caching can be had by using the version_cache, but no attempt to check
1569 to see if the on disk information is more recent than the cache is
1570 made. [This will need to be fixed for long-lived processes.]
1575 my %param = validate_with(params => \@_,
1576 spec => {bug => {type => SCALAR,
1579 found => {type => ARRAYREF,
1582 fixed => {type => ARRAYREF,
1585 version_cache => {type => HASHREF,
1588 package => {type => SCALAR,
1590 version => {type => SCALAR,
1594 my @found = @{$param{found}};
1595 my @fixed = @{$param{fixed}};
1596 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1597 # We have non-source version versions
1598 @found = makesourceversions($param{package},undef,
1601 @fixed = makesourceversions($param{package},undef,
1605 if ($param{version} !~ m{/}) {
1606 my ($version) = makesourceversions($param{package},undef,
1609 $param{version} = $version if defined $version;
1611 # Figure out which source packages we need
1613 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1614 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1615 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1616 $param{version} =~ m{/};
1618 if (not defined $param{version_cache} or
1619 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1620 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1621 foreach my $source (keys %sources) {
1622 my $srchash = substr $source, 0, 1;
1623 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1624 if (not defined $version_fh) {
1625 # We only want to warn if it's a package which actually has a maintainer
1626 my $maints = getmaintainers();
1627 next if not exists $maints->{$source};
1628 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1631 $version->load($version_fh);
1633 if (defined $param{version_cache}) {
1634 $param{version_cache}{join(',',sort keys %sources)} = $version;
1638 $version = $param{version_cache}{join(',',sort keys %sources)};
1640 return $version->buggy($param{version},\@found,\@fixed);
1643 sub isstrongseverity {
1644 my $severity = shift;
1645 $severity = $config{default_severity} if
1646 not defined $severity or $severity eq '';
1647 return grep { $_ eq $severity } @{$config{strong_severities}};
1652 =head2 generate_index_db_line
1654 my $data = read_bug(bug => $bug,
1655 location => $initialdir);
1656 # generate_index_db_line hasn't been written yet at all.
1657 my $line = generate_index_db_line($data);
1659 Returns a line for a bug suitable to be written out to index.db.
1663 sub generate_index_db_line {
1664 my ($data,$bug) = @_;
1666 # just in case someone has given us a split out data
1667 $data = join_status_fields($data);
1669 my $whendone = "open";
1670 my $severity = $config{default_severity};
1671 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1672 $pkglist =~ s/^,+//;
1673 $pkglist =~ s/,+$//;
1674 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1675 $whendone = "done" if defined $data->{done} and length $data->{done};
1676 $severity = $data->{severity} if length $data->{severity};
1677 return sprintf "%s %d %d %s [%s] %s %s\n",
1678 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1679 $data->{originator}, $severity, $data->{keywords};
1684 =head1 PRIVATE FUNCTIONS
1688 sub update_realtime {
1689 my ($file, %bugs) = @_;
1691 # update realtime index.db
1693 return () unless keys %bugs;
1694 my $idx_old = IO::File->new($file,'r')
1695 or die "Couldn't open ${file}: $!";
1696 my $idx_new = IO::File->new($file.'.new','w')
1697 or die "Couldn't open ${file}.new: $!";
1699 binmode($idx_old,':raw:utf8');
1700 binmode($idx_new,':raw:encoding(UTF-8)');
1701 my $min_bug = min(keys %bugs);
1705 while($line = <$idx_old>) {
1706 @line = split /\s/, $line;
1707 # Two cases; replacing existing line or adding new line
1708 if (exists $bugs{$line[1]}) {
1709 my $new = $bugs{$line[1]};
1710 delete $bugs{$line[1]};
1711 $min_bug = min(keys %bugs);
1712 if ($new eq "NOCHANGE") {
1713 print {$idx_new} $line;
1714 $changed_bugs{$line[1]} = $line;
1715 } elsif ($new eq "REMOVE") {
1716 $changed_bugs{$line[1]} = $line;
1718 print {$idx_new} $new;
1719 $changed_bugs{$line[1]} = $line;
1723 while ($line[1] > $min_bug) {
1724 print {$idx_new} $bugs{$min_bug};
1725 delete $bugs{$min_bug};
1726 last unless keys %bugs;
1727 $min_bug = min(keys %bugs);
1729 print {$idx_new} $line;
1731 last unless keys %bugs;
1733 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1735 print {$idx_new} <$idx_old>;
1740 rename("$file.new", $file);
1742 return %changed_bugs;
1745 sub bughook_archive {
1747 filelock("$config{spool_dir}/debbugs.trace.lock");
1748 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1749 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1750 map{($_,'REMOVE')} @refs);
1751 update_realtime("$config{spool_dir}/index.archive.realtime",
1757 my ( $type, %bugs_temp ) = @_;
1758 filelock("$config{spool_dir}/debbugs.trace.lock");
1761 for my $bug (keys %bugs_temp) {
1762 my $data = $bugs_temp{$bug};
1763 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1765 $bugs{$bug} = generate_index_db_line($data,$bug);
1767 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);