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 blocks => $ditch_empty_space,
311 blockedby => $ditch_empty_space,
312 # this isn't strictly correct, but we'll split both of them for
313 # the time being until we ditch all use of keywords everywhere
315 keywords => $ditch_empty_space,
316 tags => $ditch_empty_space,
317 found_versions => $ditch_empty_space,
318 fixed_versions => $ditch_empty_space,
319 mergedwith => $ditch_empty_space,
322 sub split_status_fields {
323 my @data = @{dclone(\@_)};
324 for my $data (@data) {
325 next if not defined $data;
326 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
327 not (ref($data) and ref($data) eq 'HASH');
328 for my $field (keys %{$data}) {
329 next unless defined $data->{$field};
330 if (exists $split_fields{$field}) {
331 next if ref($data->{$field});
333 if (ref($split_fields{$field}) eq 'CODE') {
334 @elements = &{$split_fields{$field}}($data->{$field});
336 elsif (not ref($split_fields{$field}) or
337 UNIVERSAL::isa($split_fields{$field},'Regex')
339 @elements = split $split_fields{$field}, $data->{$field};
341 $data->{$field} = \@elements;
345 return wantarray?@data:$data[0];
348 =head2 join_status_fields
350 my @data = join_status_fields(@data);
352 Handles joining the splitable status fields. (Basically, the inverse
353 of split_status_fields.
355 Primarily called from makestatus, but may be useful for other
356 functions after calling split_status_fields (or for legacy functions
357 if we transition to split fields by default).
361 sub join_status_fields {
368 found_versions => ' ',
369 fixed_versions => ' ',
374 my @data = @{dclone(\@_)};
375 for my $data (@data) {
376 next if not defined $data;
377 croak "Passed an element which is not a hashref to split_status_field: ".
379 if ref($data) ne 'HASH';
380 for my $field (keys %{$data}) {
381 next unless defined $data->{$field};
382 next unless ref($data->{$field}) eq 'ARRAY';
383 next unless exists $join_fields{$field};
384 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
387 return wantarray?@data:$data[0];
393 lockreadbug($bug_num,$location)
395 Performs a filelock, then reads the bug; the bug is unlocked if the
396 return is undefined, otherwise, you need to call unfilelock or
399 See readbug above for information on what this returns
404 my ($lref, $location) = @_;
405 return read_bug(bug => $lref, location => $location, lock => 1);
408 =head2 lockreadbugmerge
410 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
412 Performs a filelock, then reads the bug. If the bug is merged, locks
413 the merge lock. Returns a list of the number of locks and the bug
418 sub lockreadbugmerge {
419 my $data = lockreadbug(@_);
420 if (not defined $data) {
423 if (not length $data->{mergedwith}) {
427 filelock("$config{spool_dir}/lock/merge");
428 $data = lockreadbug(@_);
429 if (not defined $data) {
436 =head2 lock_read_all_merged_bugs
438 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
440 Performs a filelock, then reads the bug passed. If the bug is merged,
441 locks the merge lock, then reads and locks all of the other merged
442 bugs. Returns a list of the number of locks and the bug data for all
445 Will also return undef if any of the merged bugs failed to be read,
446 even if all of the others were read properly.
450 sub lock_read_all_merged_bugs {
451 my %param = validate_with(params => \@_,
452 spec => {bug => {type => SCALAR,
455 location => {type => SCALAR,
458 locks => {type => HASHREF,
464 my @data = read_bug(bug => $param{bug},
466 exists $param{location} ? (location => $param{location}):(),
467 exists $param{locks} ? (locks => $param{locks}):(),
469 if (not @data or not defined $data[0]) {
473 if (not length $data[0]->{mergedwith}) {
474 return ($locks,@data);
476 unfilelock(exists $param{locks}?$param{locks}:());
478 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
480 @data = read_bug(bug => $param{bug},
482 exists $param{location} ? (location => $param{location}):(),
483 exists $param{locks} ? (locks => $param{locks}):(),
485 if (not @data or not defined $data[0]) {
486 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
491 my @bugs = split / /, $data[0]->{mergedwith};
492 push @bugs, $param{bug};
493 for my $bug (@bugs) {
495 if ($bug != $param{bug}) {
497 read_bug(bug => $bug,
499 exists $param{location} ? (location => $param{location}):(),
500 exists $param{locks} ? (locks => $param{locks}):(),
502 if (not defined $newdata) {
504 unfilelock(exists $param{locks}?$param{locks}:());
507 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
512 # perform a sanity check to make sure that the merged bugs
513 # are all merged with eachother
514 # We do a cmp sort instead of an <=> sort here, because that's
516 my $expectmerge= join(' ',grep {$_ != $bug } sort @bugs);
517 if ($newdata->{mergedwith} ne $expectmerge) {
519 unfilelock(exists $param{locks}?$param{locks}:());
521 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
525 return ($locks,@data);
530 my $new_bug_num = new_bug(copy => $data->{bug_num});
532 Creates a new bug and returns the new bug number upon success.
540 validate_with(params => \@_,
541 spec => {copy => {type => SCALAR,
547 filelock("nextnumber.lock");
548 my $nn_fh = IO::File->new("nextnumber",'r') or
549 die "Unable to open nextnuber for reading: $!";
552 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
554 overwritefile("nextnumber",
557 my $nn_hash = get_hashname($nn);
559 my $c_hash = get_hashname($param{copy});
560 for my $file (qw(log status summary report)) {
561 copy("db-h/$c_hash/$param{copy}.$file",
562 "db-h/$nn_hash/${nn}.$file")
566 for my $file (qw(log status summary report)) {
567 overwritefile("db-h/$nn_hash/${nn}.$file",
572 # this probably needs to be munged to do something more elegant
573 # &bughook('new', $clone, $data);
580 my @v1fieldorder = qw(originator date subject msgid package
581 keywords done forwarded mergedwith severity);
585 my $content = makestatus($status,$version)
586 my $content = makestatus($status);
588 Creates the content for a status file based on the $status hashref
591 Really only useful for writebug
593 Currently defaults to version 2 (non-encoded rfc1522 names) but will
594 eventually default to version 3. If you care, you should specify a
600 my ($data,$version) = @_;
601 $version = 3 unless defined $version;
605 my %newdata = %$data;
606 for my $field (qw(found fixed)) {
607 if (exists $newdata{$field}) {
608 $newdata{"${field}_date"} =
609 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
612 %newdata = %{join_status_fields(\%newdata)};
614 %newdata = encode_utf8_structure(%newdata);
617 for my $field (@rfc1522_fields) {
618 $newdata{$field} = encode_rfc1522($newdata{$field});
622 # this is a bit of a hack; we should never, ever have \r or \n in
623 # the fields of status. Kill them off here. [Eventually, this
624 # should be superfluous.]
625 for my $field (keys %newdata) {
626 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
630 for my $field (@v1fieldorder) {
631 if (exists $newdata{$field} and defined $newdata{$field}) {
632 $contents .= "$newdata{$field}\n";
637 } elsif ($version == 2 or $version == 3) {
638 # Version 2 or 3. Add a file format version number for the sake of
639 # further extensibility in the future.
640 $contents .= "Format-Version: $version\n";
641 for my $field (keys %fields) {
642 if (exists $newdata{$field} and defined $newdata{$field}
643 and $newdata{$field} ne '') {
644 # Output field names in proper case, e.g. 'Merged-With'.
645 my $properfield = $fields{$field};
646 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
647 my $data = $newdata{$field};
648 $contents .= "$properfield: $data\n";
657 writebug($bug_num,$status,$location,$minversion,$disablebughook)
659 Writes the bug status and summary files out.
661 Skips writing out a status file if minversion is 2
663 Does not call bughook if disablebughook is true.
668 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
671 my %outputs = (1 => 'status', 3 => 'summary');
672 for my $version (keys %outputs) {
673 next if defined $minversion and $version < $minversion;
674 my $status = getbugcomponent($ref, $outputs{$version}, $location);
675 die "can't find location for $ref" unless defined $status;
678 open $sfh,">","$status.new" or
679 die "opening $status.new: $!";
682 open $sfh,">","$status.new" or
683 die "opening $status.new: $!";
685 print {$sfh} makestatus($data, $version) or
686 die "writing $status.new: $!";
687 close($sfh) or die "closing $status.new: $!";
693 rename("$status.new",$status) || die "installing new $status: $!";
696 # $disablebughook is a bit of a hack to let format migration scripts use
697 # this function rather than having to duplicate it themselves.
698 &bughook($change,$ref,$data) unless $disablebughook;
701 =head2 unlockwritebug
703 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
705 Writes a bug, then calls unfilelock; see writebug for what these
717 The following functions are exported with the :versions tag
719 =head2 addfoundversions
721 addfoundversions($status,$package,$version,$isbinary);
723 All use of this should be phased out in favor of Debbugs::Control::fixed/found
728 sub addfoundversions {
732 my $isbinary = shift;
733 return unless defined $version;
734 undef $package if defined $package and $package =~ m[(?:\s|/)];
735 my $source = $package;
736 if (defined $package and $package =~ s/^src://) {
741 if (defined $package and $isbinary) {
742 my @srcinfo = binary_to_source(binary => $package,
743 version => $version);
745 # We know the source package(s). Use a fully-qualified version.
746 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
749 # Otherwise, an unqualified version will have to do.
753 # Strip off various kinds of brain-damage.
755 $version =~ s/ *\(.*\)//;
756 $version =~ s/ +[A-Za-z].*//;
758 foreach my $ver (split /[,\s]+/, $version) {
759 my $sver = defined($source) ? "$source/$ver" : '';
760 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
761 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
763 @{$data->{fixed_versions}} =
764 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
768 =head2 removefoundversions
770 removefoundversions($data,$package,$versiontoremove)
772 Removes found versions from $data
774 If a version is fully qualified (contains /) only versions matching
775 exactly are removed. Otherwise, all versions matching the version
778 Currently $package and $isbinary are entirely ignored, but accepted
779 for backwards compatibility.
783 sub removefoundversions {
787 my $isbinary = shift;
788 return unless defined $version;
790 foreach my $ver (split /[,\s]+/, $version) {
792 # fully qualified version
793 @{$data->{found_versions}} =
795 @{$data->{found_versions}};
798 # non qualified version; delete all matchers
799 @{$data->{found_versions}} =
800 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
801 @{$data->{found_versions}};
807 sub addfixedversions {
811 my $isbinary = shift;
812 return unless defined $version;
813 undef $package if defined $package and $package =~ m[(?:\s|/)];
814 my $source = $package;
816 if (defined $package and $isbinary) {
817 my @srcinfo = binary_to_source(binary => $package,
818 version => $version);
820 # We know the source package(s). Use a fully-qualified version.
821 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
824 # Otherwise, an unqualified version will have to do.
828 # Strip off various kinds of brain-damage.
830 $version =~ s/ *\(.*\)//;
831 $version =~ s/ +[A-Za-z].*//;
833 foreach my $ver (split /[,\s]+/, $version) {
834 my $sver = defined($source) ? "$source/$ver" : '';
835 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
836 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
838 @{$data->{found_versions}} =
839 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
843 sub removefixedversions {
847 my $isbinary = shift;
848 return unless defined $version;
850 foreach my $ver (split /[,\s]+/, $version) {
852 # fully qualified version
853 @{$data->{fixed_versions}} =
855 @{$data->{fixed_versions}};
858 # non qualified version; delete all matchers
859 @{$data->{fixed_versions}} =
860 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
861 @{$data->{fixed_versions}};
872 Split a package string from the status file into a list of package names.
878 return unless defined $pkgs;
879 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
883 =head2 bug_archiveable
885 bug_archiveable(bug => $bug_num);
891 =item bug -- bug number (required)
893 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
895 =item version -- Debbugs::Version information (optional)
897 =item days_until -- return days until the bug can be archived
901 Returns 1 if the bug can be archived
902 Returns 0 if the bug cannot be archived
904 If days_until is true, returns the number of days until the bug can be
905 archived, -1 if it cannot be archived. 0 means that the bug can be
906 archived the next time the archiver runs.
908 Returns undef on failure.
912 # This will eventually need to be fixed before we start using mod_perl
913 our $version_cache = {};
915 my %param = validate_with(params => \@_,
916 spec => {bug => {type => SCALAR,
919 status => {type => HASHREF,
922 days_until => {type => BOOLEAN,
925 ignore_time => {type => BOOLEAN,
930 # This is what we return if the bug cannot be archived.
931 my $cannot_archive = $param{days_until}?-1:0;
932 # read the status information
933 my $status = $param{status};
934 if (not exists $param{status} or not defined $status) {
935 $status = read_bug(bug=>$param{bug});
936 if (not defined $status) {
937 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
941 # Bugs can be archived if they are
943 if (not defined $status->{done} or not length $status->{done}) {
944 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
945 return $cannot_archive
947 # Check to make sure that the bug has none of the unremovable tags set
948 if (@{$config{removal_unremovable_tags}}) {
949 for my $tag (split ' ', ($status->{keywords}||'')) {
950 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
951 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
952 return $cannot_archive;
957 # If we just are checking if the bug can be archived, we'll not even bother
958 # checking the versioning information if the bug has been -done for less than 28 days.
959 my $log_file = getbugcomponent($param{bug},'log');
960 if (not defined $log_file) {
961 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
962 return $cannot_archive;
964 my $max_log_age = max(map {$config{remove_age} - -M $_}
965 $log_file, map {my $log = getbugcomponent($_,'log');
966 defined $log ? ($log) : ();
968 split / /, $status->{mergedwith}
970 if (not $param{days_until} and not $param{ignore_time}
973 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
974 return $cannot_archive;
976 # At this point, we have to get the versioning information for this bug.
977 # We examine the set of distribution tags. If a bug has no distribution
978 # tags set, we assume a default set, otherwise we use the tags the bug
981 # In cases where we are assuming a default set, if the severity
982 # is strong, we use the strong severity default; otherwise, we
983 # use the normal default.
985 # There must be fixed_versions for us to look at the versioning
987 my $min_fixed_time = time;
988 my $min_archive_days = 0;
989 if (@{$status->{fixed_versions}}) {
991 @dist_tags{@{$config{removal_distribution_tags}}} =
992 (1) x @{$config{removal_distribution_tags}};
994 for my $tag (split ' ', ($status->{keywords}||'')) {
995 next unless exists $config{distribution_aliases}{$tag};
996 next unless $dist_tags{$config{distribution_aliases}{$tag}};
997 $dists{$config{distribution_aliases}{$tag}} = 1;
999 if (not keys %dists) {
1000 if (isstrongseverity($status->{severity})) {
1001 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1002 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1005 @dists{@{$config{removal_default_distribution_tags}}} =
1006 (1) x @{$config{removal_default_distribution_tags}};
1009 my %source_versions;
1010 my @sourceversions = get_versions(package => $status->{package},
1011 dist => [keys %dists],
1014 @source_versions{@sourceversions} = (1) x @sourceversions;
1015 # If the bug has not been fixed in the versions actually
1016 # distributed, then it cannot be archived.
1017 if ('found' eq max_buggy(bug => $param{bug},
1018 sourceversions => [keys %source_versions],
1019 found => $status->{found_versions},
1020 fixed => $status->{fixed_versions},
1021 version_cache => $version_cache,
1022 package => $status->{package},
1024 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1025 return $cannot_archive;
1027 # Since the bug has at least been fixed in the architectures
1028 # that matters, we check to see how long it has been fixed.
1030 # If $param{ignore_time}, then we should ignore time.
1031 if ($param{ignore_time}) {
1032 return $param{days_until}?0:1;
1035 # To do this, we order the times from most recent to oldest;
1036 # when we come to the first found version, we stop.
1037 # If we run out of versions, we only report the time of the
1039 my %time_versions = get_versions(package => $status->{package},
1040 dist => [keys %dists],
1044 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1045 my $buggy = buggy(bug => $param{bug},
1046 version => $version,
1047 found => $status->{found_versions},
1048 fixed => $status->{fixed_versions},
1049 version_cache => $version_cache,
1050 package => $status->{package},
1052 last if $buggy eq 'found';
1053 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1055 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1056 # if there are no versions in the archive at all, then
1057 # we can archive if enough days have passed
1060 # If $param{ignore_time}, then we should ignore time.
1061 if ($param{ignore_time}) {
1062 return $param{days_until}?0:1;
1064 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1065 my $age = ceil($max_log_age);
1066 if ($age > 0 or $min_archive_days > 0) {
1067 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1068 return $param{days_until}?max($age,$min_archive_days):0;
1071 return $param{days_until}?0:1;
1076 =head2 get_bug_status
1078 my $status = get_bug_status(bug => $nnn);
1080 my $status = get_bug_status($bug_num)
1086 =item bug -- scalar bug number
1088 =item status -- optional hashref of bug status as returned by readbug
1089 (can be passed to avoid rereading the bug information)
1091 =item bug_index -- optional tied index of bug status infomration;
1092 currently not correctly implemented.
1094 =item version -- optional version(s) to check package status at
1096 =item dist -- optional distribution(s) to check package status at
1098 =item arch -- optional architecture(s) to check package status at
1100 =item bugusertags -- optional hashref of bugusertags
1102 =item sourceversion -- optional arrayref of source/version; overrides
1103 dist, arch, and version. [The entries in this array must be in the
1104 "source/version" format.] Eventually this can be used to for caching.
1106 =item indicatesource -- if true, indicate which source packages this
1107 bug could belong to (or does belong to in the case of bugs assigned to
1108 a source package). Defaults to true.
1112 Note: Currently the version information is cached; this needs to be
1113 changed before using this function in long lived programs.
1117 Currently returns a hashref of status with the following keys.
1121 =item id -- bug number
1123 =item bug_num -- duplicate of id
1125 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1127 =item tags -- duplicate of keywords
1129 =item package -- name of package that the bug is assigned to
1131 =item severity -- severity of the bug
1133 =item pending -- pending state of the bug; one of following possible
1134 values; values listed later have precedence if multiple conditions are
1139 =item pending -- default state
1141 =item forwarded -- bug has been forwarded
1143 =item pending-fixed -- bug is tagged pending
1145 =item fixed -- bug is tagged fixed
1147 =item absent -- bug does not apply to this distribution/architecture
1149 =item done -- bug is resolved in this distribution/architecture
1153 =item location -- db-h or archive; the location in the filesystem
1155 =item subject -- title of the bug
1157 =item last_modified -- epoch that the bug was last modified
1159 =item date -- epoch that the bug was filed
1161 =item originator -- bug reporter
1163 =item log_modified -- epoch that the log file was last modified
1165 =item msgid -- Message id of the original bug report
1170 Other key/value pairs are returned but are not currently documented here.
1174 sub get_bug_status {
1178 my %param = validate_with(params => \@_,
1179 spec => {bug => {type => SCALAR,
1182 status => {type => HASHREF,
1185 bug_index => {type => OBJECT,
1188 version => {type => SCALAR|ARRAYREF,
1191 dist => {type => SCALAR|ARRAYREF,
1194 arch => {type => SCALAR|ARRAYREF,
1197 bugusertags => {type => HASHREF,
1200 sourceversions => {type => ARRAYREF,
1203 indicatesource => {type => BOOLEAN,
1210 if (defined $param{bug_index} and
1211 exists $param{bug_index}{$param{bug}}) {
1212 %status = %{ $param{bug_index}{$param{bug}} };
1213 $status{pending} = $status{ status };
1214 $status{id} = $param{bug};
1217 if (defined $param{status}) {
1218 %status = %{$param{status}};
1221 my $location = getbuglocation($param{bug}, 'summary');
1222 return {} if not defined $location or not length $location;
1223 %status = %{ readbug( $param{bug}, $location ) };
1225 $status{id} = $param{bug};
1227 if (defined $param{bugusertags}{$param{bug}}) {
1228 $status{keywords} = "" unless defined $status{keywords};
1229 $status{keywords} .= " " unless $status{keywords} eq "";
1230 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1232 $status{tags} = $status{keywords};
1233 my %tags = map { $_ => 1 } split ' ', $status{tags};
1235 $status{package} = '' if not defined $status{package};
1236 $status{"package"} =~ s/\s*$//;
1238 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1242 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1243 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1245 $status{"pending"} = 'pending';
1246 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1247 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1248 $status{"pending"} = 'fixed' if ($tags{fixed});
1251 my $presence = bug_presence(status => \%status,
1252 map{(exists $param{$_})?($_,$param{$_}):()}
1253 qw(bug sourceversions arch dist version found fixed package)
1255 if (defined $presence) {
1256 if ($presence eq 'fixed') {
1257 $status{pending} = 'done';
1259 elsif ($presence eq 'absent') {
1260 $status{pending} = 'absent';
1268 my $precence = bug_presence(bug => nnn,
1272 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1273 is found, absent, fixed, or no information is available in the
1274 distribution (dist) and/or architecture (arch) specified.
1281 =item bug -- scalar bug number
1283 =item status -- optional hashref of bug status as returned by readbug
1284 (can be passed to avoid rereading the bug information)
1286 =item bug_index -- optional tied index of bug status infomration;
1287 currently not correctly implemented.
1289 =item version -- optional version to check package status at
1291 =item dist -- optional distribution to check package status at
1293 =item arch -- optional architecture to check package status at
1295 =item sourceversion -- optional arrayref of source/version; overrides
1296 dist, arch, and version. [The entries in this array must be in the
1297 "source/version" format.] Eventually this can be used to for caching.
1304 my %param = validate_with(params => \@_,
1305 spec => {bug => {type => SCALAR,
1308 status => {type => HASHREF,
1311 version => {type => SCALAR|ARRAYREF,
1314 dist => {type => SCALAR|ARRAYREF,
1317 arch => {type => SCALAR|ARRAYREF,
1320 sourceversions => {type => ARRAYREF,
1326 if (defined $param{status}) {
1327 %status = %{$param{status}};
1330 my $location = getbuglocation($param{bug}, 'summary');
1331 return {} if not length $location;
1332 %status = %{ readbug( $param{bug}, $location ) };
1336 my $pseudo_desc = getpseudodesc();
1337 if (not exists $param{sourceversions}) {
1339 # pseudopackages do not have source versions by definition.
1340 if (exists $pseudo_desc->{$status{package}}) {
1343 elsif (defined $param{version}) {
1344 foreach my $arch (make_list($param{arch})) {
1345 for my $package (split /\s*,\s*/, $status{package}) {
1346 my @temp = makesourceversions($package,
1348 make_list($param{version})
1350 @sourceversions{@temp} = (1) x @temp;
1353 } elsif (defined $param{dist}) {
1354 my %affects_distribution_tags;
1355 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1356 (1) x @{$config{affects_distribution_tags}};
1357 my $some_distributions_disallowed = 0;
1358 my %allowed_distributions;
1359 for my $tag (split ' ', ($status{keywords}||'')) {
1360 if (exists $config{distribution_aliases}{$tag} and
1361 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1362 $some_distributions_disallowed = 1;
1363 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1365 elsif (exists $affects_distribution_tags{$tag}) {
1366 $some_distributions_disallowed = 1;
1367 $allowed_distributions{$tag} = 1;
1370 my @archs = make_list(exists $param{arch}?$param{arch}:());
1371 GET_SOURCE_VERSIONS:
1372 foreach my $arch (@archs) {
1373 for my $package (split /\s*,\s*/, $status{package}) {
1376 if ($package =~ /^src:(.+)$/) {
1380 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1381 # if some distributions are disallowed,
1382 # and this isn't an allowed
1383 # distribution, then we ignore this
1384 # distribution for the purposees of
1386 if ($some_distributions_disallowed and
1387 not exists $allowed_distributions{$dist}) {
1390 push @versions, get_versions(package => $package,
1392 ($source?(arch => 'source'):
1393 (defined $arch?(arch => $arch):())),
1396 next unless @versions;
1397 my @temp = make_source_versions(package => $package,
1399 versions => \@versions,
1401 @sourceversions{@temp} = (1) x @temp;
1404 # this should really be split out into a subroutine,
1405 # but it'd touch so many things currently, that we fake
1406 # it; it's needed to properly handle bugs which are
1407 # erroneously assigned to the binary package, and we'll
1408 # probably have it go away eventually.
1409 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1411 goto GET_SOURCE_VERSIONS;
1415 # TODO: This should probably be handled further out for efficiency and
1416 # for more ease of distinguishing between pkg= and src= queries.
1417 # DLA: src= queries should just pass arch=source, and they'll be happy.
1418 @sourceversions = keys %sourceversions;
1421 @sourceversions = @{$param{sourceversions}};
1423 my $maxbuggy = 'undef';
1424 if (@sourceversions) {
1425 $maxbuggy = max_buggy(bug => $param{bug},
1426 sourceversions => \@sourceversions,
1427 found => $status{found_versions},
1428 fixed => $status{fixed_versions},
1429 package => $status{package},
1430 version_cache => $version_cache,
1433 elsif (defined $param{dist} and
1434 not exists $pseudo_desc->{$status{package}}) {
1437 if (length($status{done}) and
1438 (not @sourceversions or not @{$status{fixed_versions}})) {
1453 =item bug -- scalar bug number
1455 =item sourceversion -- optional arrayref of source/version; overrides
1456 dist, arch, and version. [The entries in this array must be in the
1457 "source/version" format.] Eventually this can be used to for caching.
1461 Note: Currently the version information is cached; this needs to be
1462 changed before using this function in long lived programs.
1467 my %param = validate_with(params => \@_,
1468 spec => {bug => {type => SCALAR,
1471 sourceversions => {type => ARRAYREF,
1474 found => {type => ARRAYREF,
1477 fixed => {type => ARRAYREF,
1480 package => {type => SCALAR,
1482 version_cache => {type => HASHREF,
1487 # Resolve bugginess states (we might be looking at multiple
1488 # architectures, say). Found wins, then fixed, then absent.
1489 my $maxbuggy = 'absent';
1490 for my $package (split /\s*,\s*/, $param{package}) {
1491 for my $version (@{$param{sourceversions}}) {
1492 my $buggy = buggy(bug => $param{bug},
1493 version => $version,
1494 found => $param{found},
1495 fixed => $param{fixed},
1496 version_cache => $param{version_cache},
1497 package => $package,
1499 if ($buggy eq 'found') {
1501 } elsif ($buggy eq 'fixed') {
1502 $maxbuggy = 'fixed';
1519 Returns the output of Debbugs::Versions::buggy for a particular
1520 package, version and found/fixed set. Automatically turns found, fixed
1521 and version into source/version strings.
1523 Caching can be had by using the version_cache, but no attempt to check
1524 to see if the on disk information is more recent than the cache is
1525 made. [This will need to be fixed for long-lived processes.]
1530 my %param = validate_with(params => \@_,
1531 spec => {bug => {type => SCALAR,
1534 found => {type => ARRAYREF,
1537 fixed => {type => ARRAYREF,
1540 version_cache => {type => HASHREF,
1543 package => {type => SCALAR,
1545 version => {type => SCALAR,
1549 my @found = @{$param{found}};
1550 my @fixed = @{$param{fixed}};
1551 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1552 # We have non-source version versions
1553 @found = makesourceversions($param{package},undef,
1556 @fixed = makesourceversions($param{package},undef,
1560 if ($param{version} !~ m{/}) {
1561 my ($version) = makesourceversions($param{package},undef,
1564 $param{version} = $version if defined $version;
1566 # Figure out which source packages we need
1568 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1569 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1570 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1571 $param{version} =~ m{/};
1573 if (not defined $param{version_cache} or
1574 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1575 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1576 foreach my $source (keys %sources) {
1577 my $srchash = substr $source, 0, 1;
1578 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1579 if (not defined $version_fh) {
1580 # We only want to warn if it's a package which actually has a maintainer
1581 my $maints = getmaintainers();
1582 next if not exists $maints->{$source};
1583 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1586 $version->load($version_fh);
1588 if (defined $param{version_cache}) {
1589 $param{version_cache}{join(',',sort keys %sources)} = $version;
1593 $version = $param{version_cache}{join(',',sort keys %sources)};
1595 return $version->buggy($param{version},\@found,\@fixed);
1598 sub isstrongseverity {
1599 my $severity = shift;
1600 $severity = $config{default_severity} if
1601 not defined $severity or $severity eq '';
1602 return grep { $_ eq $severity } @{$config{strong_severities}};
1607 =head2 generate_index_db_line
1609 my $data = read_bug(bug => $bug,
1610 location => $initialdir);
1611 # generate_index_db_line hasn't been written yet at all.
1612 my $line = generate_index_db_line($data);
1614 Returns a line for a bug suitable to be written out to index.db.
1618 sub generate_index_db_line {
1619 my ($data,$bug) = @_;
1621 # just in case someone has given us a split out data
1622 $data = join_status_fields($data);
1624 my $whendone = "open";
1625 my $severity = $config{default_severity};
1626 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1627 $pkglist =~ s/^,+//;
1628 $pkglist =~ s/,+$//;
1629 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1630 $whendone = "done" if defined $data->{done} and length $data->{done};
1631 $severity = $data->{severity} if length $data->{severity};
1632 return sprintf "%s %d %d %s [%s] %s %s\n",
1633 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1634 $data->{originator}, $severity, $data->{keywords};
1639 =head1 PRIVATE FUNCTIONS
1643 sub update_realtime {
1644 my ($file, %bugs) = @_;
1646 # update realtime index.db
1648 return () unless keys %bugs;
1649 my $idx_old = IO::File->new($file,'r')
1650 or die "Couldn't open ${file}: $!";
1651 my $idx_new = IO::File->new($file.'.new','w')
1652 or die "Couldn't open ${file}.new: $!";
1654 binmode($idx_old,':raw:utf8');
1655 binmode($idx_new,':raw:encoding(UTF-8)');
1656 my $min_bug = min(keys %bugs);
1660 while($line = <$idx_old>) {
1661 @line = split /\s/, $line;
1662 # Two cases; replacing existing line or adding new line
1663 if (exists $bugs{$line[1]}) {
1664 my $new = $bugs{$line[1]};
1665 delete $bugs{$line[1]};
1666 $min_bug = min(keys %bugs);
1667 if ($new eq "NOCHANGE") {
1668 print {$idx_new} $line;
1669 $changed_bugs{$line[1]} = $line;
1670 } elsif ($new eq "REMOVE") {
1671 $changed_bugs{$line[1]} = $line;
1673 print {$idx_new} $new;
1674 $changed_bugs{$line[1]} = $line;
1678 while ($line[1] > $min_bug) {
1679 print {$idx_new} $bugs{$min_bug};
1680 delete $bugs{$min_bug};
1681 last unless keys %bugs;
1682 $min_bug = min(keys %bugs);
1684 print {$idx_new} $line;
1686 last unless keys %bugs;
1688 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1690 print {$idx_new} <$idx_old>;
1695 rename("$file.new", $file);
1697 return %changed_bugs;
1700 sub bughook_archive {
1702 filelock("$config{spool_dir}/debbugs.trace.lock");
1703 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1704 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1705 map{($_,'REMOVE')} @refs);
1706 update_realtime("$config{spool_dir}/index.archive.realtime",
1712 my ( $type, %bugs_temp ) = @_;
1713 filelock("$config{spool_dir}/debbugs.trace.lock");
1716 for my $bug (keys %bugs_temp) {
1717 my $data = $bugs_temp{$bug};
1718 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1720 $bugs{$bug} = generate_index_db_line($data,$bug);
1722 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);