1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Status;
14 Debbugs::Status -- Routines for dealing with summary and status files
23 This module is a replacement for the parts of errorlib.pl which write
24 and read status and summary files.
26 It also contains generic routines for returning information about the
27 status of a particular bug
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(:util :lock :quit :misc);
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}_date"}} - @{$data{"${field}_versions"}}),
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 ($bug_num,$location) = @_;
420 my $data = lockreadbug(@_);
421 if (not defined $data) {
424 if (not length $data->{mergedwith}) {
428 filelock("$config{spool_dir}/lock/merge");
429 $data = lockreadbug(@_);
430 if (not defined $data) {
437 =head2 lock_read_all_merged_bugs
439 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
441 Performs a filelock, then reads the bug passed. If the bug is merged,
442 locks the merge lock, then reads and locks all of the other merged
443 bugs. Returns a list of the number of locks and the bug data for all
446 Will also return undef if any of the merged bugs failed to be read,
447 even if all of the others were read properly.
451 sub lock_read_all_merged_bugs {
452 my %param = validate_with(params => \@_,
453 spec => {bug => {type => SCALAR,
456 location => {type => SCALAR,
459 locks => {type => HASHREF,
465 my @data = read_bug(bug => $param{bug},
467 exists $param{location} ? (location => $param{location}):(),
468 exists $param{locks} ? (locks => $param{locks}):(),
470 if (not @data or not defined $data[0]) {
474 if (not length $data[0]->{mergedwith}) {
475 return ($locks,@data);
477 unfilelock(exists $param{locks}?$param{locks}:());
479 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
481 @data = read_bug(bug => $param{bug},
483 exists $param{location} ? (location => $param{location}):(),
484 exists $param{locks} ? (locks => $param{locks}):(),
486 if (not @data or not defined $data[0]) {
487 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
492 my @bugs = split / /, $data[0]->{mergedwith};
493 push @bugs, $param{bug};
494 for my $bug (@bugs) {
496 if ($bug != $param{bug}) {
498 read_bug(bug => $bug,
500 exists $param{location} ? (location => $param{location}):(),
501 exists $param{locks} ? (locks => $param{locks}):(),
503 if (not defined $newdata) {
505 unfilelock(exists $param{locks}?$param{locks}:());
508 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
513 # perform a sanity check to make sure that the merged bugs
514 # are all merged with eachother
515 # We do a cmp sort instead of an <=> sort here, because that's
517 my $expectmerge= join(' ',grep {$_ != $bug } sort @bugs);
518 if ($newdata->{mergedwith} ne $expectmerge) {
520 unfilelock(exists $param{locks}?$param{locks}:());
522 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
526 return ($locks,@data);
531 my $new_bug_num = new_bug(copy => $data->{bug_num});
533 Creates a new bug and returns the new bug number upon success.
541 validate_with(params => \@_,
542 spec => {copy => {type => SCALAR,
548 filelock("nextnumber.lock");
549 my $nn_fh = IO::File->new("nextnumber",'r') or
550 die "Unable to open nextnuber for reading: $!";
553 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
555 overwritefile("nextnumber",
558 my $nn_hash = get_hashname($nn);
560 my $c_hash = get_hashname($param{copy});
561 for my $file (qw(log status summary report)) {
562 copy("db-h/$c_hash/$param{copy}.$file",
563 "db-h/$nn_hash/${nn}.$file")
567 for my $file (qw(log status summary report)) {
568 overwritefile("db-h/$nn_hash/${nn}.$file",
573 # this probably needs to be munged to do something more elegant
574 # &bughook('new', $clone, $data);
581 my @v1fieldorder = qw(originator date subject msgid package
582 keywords done forwarded mergedwith severity);
586 my $content = makestatus($status,$version)
587 my $content = makestatus($status);
589 Creates the content for a status file based on the $status hashref
592 Really only useful for writebug
594 Currently defaults to version 2 (non-encoded rfc1522 names) but will
595 eventually default to version 3. If you care, you should specify a
601 my ($data,$version) = @_;
602 $version = 3 unless defined $version;
606 my %newdata = %$data;
607 for my $field (qw(found fixed)) {
608 if (exists $newdata{$field}) {
609 $newdata{"${field}_date"} =
610 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
613 %newdata = %{join_status_fields(\%newdata)};
615 %newdata = encode_utf8_structure(%newdata);
618 for my $field (@rfc1522_fields) {
619 $newdata{$field} = encode_rfc1522($newdata{$field});
623 # this is a bit of a hack; we should never, ever have \r or \n in
624 # the fields of status. Kill them off here. [Eventually, this
625 # should be superfluous.]
626 for my $field (keys %newdata) {
627 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
631 for my $field (@v1fieldorder) {
632 if (exists $newdata{$field} and defined $newdata{$field}) {
633 $contents .= "$newdata{$field}\n";
638 } elsif ($version == 2 or $version == 3) {
639 # Version 2 or 3. Add a file format version number for the sake of
640 # further extensibility in the future.
641 $contents .= "Format-Version: $version\n";
642 for my $field (keys %fields) {
643 if (exists $newdata{$field} and defined $newdata{$field}
644 and $newdata{$field} ne '') {
645 # Output field names in proper case, e.g. 'Merged-With'.
646 my $properfield = $fields{$field};
647 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
648 my $data = $newdata{$field};
649 $contents .= "$properfield: $data\n";
658 writebug($bug_num,$status,$location,$minversion,$disablebughook)
660 Writes the bug status and summary files out.
662 Skips writing out a status file if minversion is 2
664 Does not call bughook if disablebughook is true.
669 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
672 my %outputs = (1 => 'status', 3 => 'summary');
673 for my $version (keys %outputs) {
674 next if defined $minversion and $version < $minversion;
675 my $status = getbugcomponent($ref, $outputs{$version}, $location);
676 die "can't find location for $ref" unless defined $status;
679 open $sfh,">","$status.new" or
680 die "opening $status.new: $!";
683 open $sfh,">","$status.new" or
684 die "opening $status.new: $!";
686 print {$sfh} makestatus($data, $version) or
687 die "writing $status.new: $!";
688 close($sfh) or die "closing $status.new: $!";
694 rename("$status.new",$status) || die "installing new $status: $!";
697 # $disablebughook is a bit of a hack to let format migration scripts use
698 # this function rather than having to duplicate it themselves.
699 &bughook($change,$ref,$data) unless $disablebughook;
702 =head2 unlockwritebug
704 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
706 Writes a bug, then calls unfilelock; see writebug for what these
718 The following functions are exported with the :versions tag
720 =head2 addfoundversions
722 addfoundversions($status,$package,$version,$isbinary);
724 All use of this should be phased out in favor of Debbugs::Control::fixed/found
729 sub addfoundversions {
733 my $isbinary = shift;
734 return unless defined $version;
735 undef $package if defined $package and $package =~ m[(?:\s|/)];
736 my $source = $package;
737 if (defined $package and $package =~ s/^src://) {
742 if (defined $package and $isbinary) {
743 my @srcinfo = binary_to_source(binary => $package,
744 version => $version);
746 # We know the source package(s). Use a fully-qualified version.
747 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
750 # Otherwise, an unqualified version will have to do.
754 # Strip off various kinds of brain-damage.
756 $version =~ s/ *\(.*\)//;
757 $version =~ s/ +[A-Za-z].*//;
759 foreach my $ver (split /[,\s]+/, $version) {
760 my $sver = defined($source) ? "$source/$ver" : '';
761 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
762 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
764 @{$data->{fixed_versions}} =
765 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
769 =head2 removefoundversions
771 removefoundversions($data,$package,$versiontoremove)
773 Removes found versions from $data
775 If a version is fully qualified (contains /) only versions matching
776 exactly are removed. Otherwise, all versions matching the version
779 Currently $package and $isbinary are entirely ignored, but accepted
780 for backwards compatibility.
784 sub removefoundversions {
788 my $isbinary = shift;
789 return unless defined $version;
791 foreach my $ver (split /[,\s]+/, $version) {
793 # fully qualified version
794 @{$data->{found_versions}} =
796 @{$data->{found_versions}};
799 # non qualified version; delete all matchers
800 @{$data->{found_versions}} =
801 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
802 @{$data->{found_versions}};
808 sub addfixedversions {
812 my $isbinary = shift;
813 return unless defined $version;
814 undef $package if defined $package and $package =~ m[(?:\s|/)];
815 my $source = $package;
817 if (defined $package and $isbinary) {
818 my @srcinfo = binary_to_source(binary => $package,
819 version => $version);
821 # We know the source package(s). Use a fully-qualified version.
822 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
825 # Otherwise, an unqualified version will have to do.
829 # Strip off various kinds of brain-damage.
831 $version =~ s/ *\(.*\)//;
832 $version =~ s/ +[A-Za-z].*//;
834 foreach my $ver (split /[,\s]+/, $version) {
835 my $sver = defined($source) ? "$source/$ver" : '';
836 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
837 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
839 @{$data->{found_versions}} =
840 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
844 sub removefixedversions {
848 my $isbinary = shift;
849 return unless defined $version;
851 foreach my $ver (split /[,\s]+/, $version) {
853 # fully qualified version
854 @{$data->{fixed_versions}} =
856 @{$data->{fixed_versions}};
859 # non qualified version; delete all matchers
860 @{$data->{fixed_versions}} =
861 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
862 @{$data->{fixed_versions}};
873 Split a package string from the status file into a list of package names.
879 return unless defined $pkgs;
880 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
884 =head2 bug_archiveable
886 bug_archiveable(bug => $bug_num);
892 =item bug -- bug number (required)
894 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
896 =item version -- Debbugs::Version information (optional)
898 =item days_until -- return days until the bug can be archived
902 Returns 1 if the bug can be archived
903 Returns 0 if the bug cannot be archived
905 If days_until is true, returns the number of days until the bug can be
906 archived, -1 if it cannot be archived. 0 means that the bug can be
907 archived the next time the archiver runs.
909 Returns undef on failure.
913 # This will eventually need to be fixed before we start using mod_perl
914 our $version_cache = {};
916 my %param = validate_with(params => \@_,
917 spec => {bug => {type => SCALAR,
920 status => {type => HASHREF,
923 days_until => {type => BOOLEAN,
926 ignore_time => {type => BOOLEAN,
931 # This is what we return if the bug cannot be archived.
932 my $cannot_archive = $param{days_until}?-1:0;
933 # read the status information
934 my $status = $param{status};
935 if (not exists $param{status} or not defined $status) {
936 $status = read_bug(bug=>$param{bug});
937 if (not defined $status) {
938 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
942 # Bugs can be archived if they are
944 if (not defined $status->{done} or not length $status->{done}) {
945 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
946 return $cannot_archive
948 # Check to make sure that the bug has none of the unremovable tags set
949 if (@{$config{removal_unremovable_tags}}) {
950 for my $tag (split ' ', ($status->{keywords}||'')) {
951 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
952 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
953 return $cannot_archive;
958 # If we just are checking if the bug can be archived, we'll not even bother
959 # checking the versioning information if the bug has been -done for less than 28 days.
960 my $log_file = getbugcomponent($param{bug},'log');
961 if (not defined $log_file) {
962 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
963 return $cannot_archive;
965 my $max_log_age = max(map {$config{remove_age} - -M $_}
966 $log_file, map {my $log = getbugcomponent($_,'log');
967 defined $log ? ($log) : ();
969 split / /, $status->{mergedwith}
971 if (not $param{days_until} and not $param{ignore_time}
974 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
975 return $cannot_archive;
977 # At this point, we have to get the versioning information for this bug.
978 # We examine the set of distribution tags. If a bug has no distribution
979 # tags set, we assume a default set, otherwise we use the tags the bug
982 # In cases where we are assuming a default set, if the severity
983 # is strong, we use the strong severity default; otherwise, we
984 # use the normal default.
986 # There must be fixed_versions for us to look at the versioning
988 my $min_fixed_time = time;
989 my $min_archive_days = 0;
990 if (@{$status->{fixed_versions}}) {
992 @dist_tags{@{$config{removal_distribution_tags}}} =
993 (1) x @{$config{removal_distribution_tags}};
995 for my $tag (split ' ', ($status->{keywords}||'')) {
996 next unless exists $config{distribution_aliases}{$tag};
997 next unless $dist_tags{$config{distribution_aliases}{$tag}};
998 $dists{$config{distribution_aliases}{$tag}} = 1;
1000 if (not keys %dists) {
1001 if (isstrongseverity($status->{severity})) {
1002 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1003 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1006 @dists{@{$config{removal_default_distribution_tags}}} =
1007 (1) x @{$config{removal_default_distribution_tags}};
1010 my %source_versions;
1011 my @sourceversions = get_versions(package => $status->{package},
1012 dist => [keys %dists],
1015 @source_versions{@sourceversions} = (1) x @sourceversions;
1016 # If the bug has not been fixed in the versions actually
1017 # distributed, then it cannot be archived.
1018 if ('found' eq max_buggy(bug => $param{bug},
1019 sourceversions => [keys %source_versions],
1020 found => $status->{found_versions},
1021 fixed => $status->{fixed_versions},
1022 version_cache => $version_cache,
1023 package => $status->{package},
1025 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1026 return $cannot_archive;
1028 # Since the bug has at least been fixed in the architectures
1029 # that matters, we check to see how long it has been fixed.
1031 # If $param{ignore_time}, then we should ignore time.
1032 if ($param{ignore_time}) {
1033 return $param{days_until}?0:1;
1036 # To do this, we order the times from most recent to oldest;
1037 # when we come to the first found version, we stop.
1038 # If we run out of versions, we only report the time of the
1040 my %time_versions = get_versions(package => $status->{package},
1041 dist => [keys %dists],
1045 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1046 my $buggy = buggy(bug => $param{bug},
1047 version => $version,
1048 found => $status->{found_versions},
1049 fixed => $status->{fixed_versions},
1050 version_cache => $version_cache,
1051 package => $status->{package},
1053 last if $buggy eq 'found';
1054 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1056 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1057 # if there are no versions in the archive at all, then
1058 # we can archive if enough days have passed
1061 # If $param{ignore_time}, then we should ignore time.
1062 if ($param{ignore_time}) {
1063 return $param{days_until}?0:1;
1065 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1066 my $age = ceil($max_log_age);
1067 if ($age > 0 or $min_archive_days > 0) {
1068 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1069 return $param{days_until}?max($age,$min_archive_days):0;
1072 return $param{days_until}?0:1;
1077 =head2 get_bug_status
1079 my $status = get_bug_status(bug => $nnn);
1081 my $status = get_bug_status($bug_num)
1087 =item bug -- scalar bug number
1089 =item status -- optional hashref of bug status as returned by readbug
1090 (can be passed to avoid rereading the bug information)
1092 =item bug_index -- optional tied index of bug status infomration;
1093 currently not correctly implemented.
1095 =item version -- optional version(s) to check package status at
1097 =item dist -- optional distribution(s) to check package status at
1099 =item arch -- optional architecture(s) to check package status at
1101 =item bugusertags -- optional hashref of bugusertags
1103 =item sourceversion -- optional arrayref of source/version; overrides
1104 dist, arch, and version. [The entries in this array must be in the
1105 "source/version" format.] Eventually this can be used to for caching.
1107 =item indicatesource -- if true, indicate which source packages this
1108 bug could belong to (or does belong to in the case of bugs assigned to
1109 a source package). Defaults to true.
1113 Note: Currently the version information is cached; this needs to be
1114 changed before using this function in long lived programs.
1118 Currently returns a hashref of status with the following keys.
1122 =item id -- bug number
1124 =item bug_num -- duplicate of id
1126 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1128 =item tags -- duplicate of keywords
1130 =item package -- name of package that the bug is assigned to
1132 =item severity -- severity of the bug
1134 =item pending -- pending state of the bug; one of following possible
1135 values; values listed later have precedence if multiple conditions are
1140 =item pending -- default state
1142 =item forwarded -- bug has been forwarded
1144 =item pending-fixed -- bug is tagged pending
1146 =item fixed -- bug is tagged fixed
1148 =item absent -- bug does not apply to this distribution/architecture
1150 =item done -- bug is resolved in this distribution/architecture
1154 =item location -- db-h or archive; the location in the filesystem
1156 =item subject -- title of the bug
1158 =item last_modified -- epoch that the bug was last modified
1160 =item date -- epoch that the bug was filed
1162 =item originator -- bug reporter
1164 =item log_modified -- epoch that the log file was last modified
1166 =item msgid -- Message id of the original bug report
1171 Other key/value pairs are returned but are not currently documented here.
1175 sub get_bug_status {
1179 my %param = validate_with(params => \@_,
1180 spec => {bug => {type => SCALAR,
1183 status => {type => HASHREF,
1186 bug_index => {type => OBJECT,
1189 version => {type => SCALAR|ARRAYREF,
1192 dist => {type => SCALAR|ARRAYREF,
1195 arch => {type => SCALAR|ARRAYREF,
1198 bugusertags => {type => HASHREF,
1201 sourceversions => {type => ARRAYREF,
1204 indicatesource => {type => BOOLEAN,
1211 if (defined $param{bug_index} and
1212 exists $param{bug_index}{$param{bug}}) {
1213 %status = %{ $param{bug_index}{$param{bug}} };
1214 $status{pending} = $status{ status };
1215 $status{id} = $param{bug};
1218 if (defined $param{status}) {
1219 %status = %{$param{status}};
1222 my $location = getbuglocation($param{bug}, 'summary');
1223 return {} if not defined $location or not length $location;
1224 %status = %{ readbug( $param{bug}, $location ) };
1226 $status{id} = $param{bug};
1228 if (defined $param{bugusertags}{$param{bug}}) {
1229 $status{keywords} = "" unless defined $status{keywords};
1230 $status{keywords} .= " " unless $status{keywords} eq "";
1231 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1233 $status{tags} = $status{keywords};
1234 my %tags = map { $_ => 1 } split ' ', $status{tags};
1236 $status{package} = '' if not defined $status{package};
1237 $status{"package"} =~ s/\s*$//;
1239 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1243 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1244 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1246 $status{"pending"} = 'pending';
1247 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1248 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1249 $status{"pending"} = 'fixed' if ($tags{fixed});
1252 my $presence = bug_presence(status => \%status,
1253 map{(exists $param{$_})?($_,$param{$_}):()}
1254 qw(bug sourceversions arch dist version found fixed package)
1256 if (defined $presence) {
1257 if ($presence eq 'fixed') {
1258 $status{pending} = 'done';
1260 elsif ($presence eq 'absent') {
1261 $status{pending} = 'absent';
1269 my $precence = bug_presence(bug => nnn,
1273 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1274 is found, absent, fixed, or no information is available in the
1275 distribution (dist) and/or architecture (arch) specified.
1282 =item bug -- scalar bug number
1284 =item status -- optional hashref of bug status as returned by readbug
1285 (can be passed to avoid rereading the bug information)
1287 =item bug_index -- optional tied index of bug status infomration;
1288 currently not correctly implemented.
1290 =item version -- optional version to check package status at
1292 =item dist -- optional distribution to check package status at
1294 =item arch -- optional architecture to check package status at
1296 =item sourceversion -- optional arrayref of source/version; overrides
1297 dist, arch, and version. [The entries in this array must be in the
1298 "source/version" format.] Eventually this can be used to for caching.
1305 my %param = validate_with(params => \@_,
1306 spec => {bug => {type => SCALAR,
1309 status => {type => HASHREF,
1312 version => {type => SCALAR|ARRAYREF,
1315 dist => {type => SCALAR|ARRAYREF,
1318 arch => {type => SCALAR|ARRAYREF,
1321 sourceversions => {type => ARRAYREF,
1327 if (defined $param{status}) {
1328 %status = %{$param{status}};
1331 my $location = getbuglocation($param{bug}, 'summary');
1332 return {} if not length $location;
1333 %status = %{ readbug( $param{bug}, $location ) };
1337 my $pseudo_desc = getpseudodesc();
1338 if (not exists $param{sourceversions}) {
1340 # pseudopackages do not have source versions by definition.
1341 if (exists $pseudo_desc->{$status{package}}) {
1344 elsif (defined $param{version}) {
1345 foreach my $arch (make_list($param{arch})) {
1346 for my $package (split /\s*,\s*/, $status{package}) {
1347 my @temp = makesourceversions($package,
1349 make_list($param{version})
1351 @sourceversions{@temp} = (1) x @temp;
1354 } elsif (defined $param{dist}) {
1355 my %affects_distribution_tags;
1356 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1357 (1) x @{$config{affects_distribution_tags}};
1358 my $some_distributions_disallowed = 0;
1359 my %allowed_distributions;
1360 for my $tag (split ' ', ($status{keywords}||'')) {
1361 if (exists $config{distribution_aliases}{$tag} and
1362 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1363 $some_distributions_disallowed = 1;
1364 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1366 elsif (exists $affects_distribution_tags{$tag}) {
1367 $some_distributions_disallowed = 1;
1368 $allowed_distributions{$tag} = 1;
1371 my @archs = make_list(exists $param{arch}?$param{arch}:());
1372 GET_SOURCE_VERSIONS:
1373 foreach my $arch (@archs) {
1374 for my $package (split /\s*,\s*/, $status{package}) {
1377 if ($package =~ /^src:(.+)$/) {
1381 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1382 # if some distributions are disallowed,
1383 # and this isn't an allowed
1384 # distribution, then we ignore this
1385 # distribution for the purposees of
1387 if ($some_distributions_disallowed and
1388 not exists $allowed_distributions{$dist}) {
1391 push @versions, get_versions(package => $package,
1393 ($source?(arch => 'source'):
1394 (defined $arch?(arch => $arch):())),
1397 next unless @versions;
1398 my @temp = make_source_versions(package => $package,
1400 versions => \@versions,
1402 @sourceversions{@temp} = (1) x @temp;
1405 # this should really be split out into a subroutine,
1406 # but it'd touch so many things currently, that we fake
1407 # it; it's needed to properly handle bugs which are
1408 # erroneously assigned to the binary package, and we'll
1409 # probably have it go away eventually.
1410 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1412 goto GET_SOURCE_VERSIONS;
1416 # TODO: This should probably be handled further out for efficiency and
1417 # for more ease of distinguishing between pkg= and src= queries.
1418 # DLA: src= queries should just pass arch=source, and they'll be happy.
1419 @sourceversions = keys %sourceversions;
1422 @sourceversions = @{$param{sourceversions}};
1424 my $maxbuggy = 'undef';
1425 if (@sourceversions) {
1426 $maxbuggy = max_buggy(bug => $param{bug},
1427 sourceversions => \@sourceversions,
1428 found => $status{found_versions},
1429 fixed => $status{fixed_versions},
1430 package => $status{package},
1431 version_cache => $version_cache,
1434 elsif (defined $param{dist} and
1435 not exists $pseudo_desc->{$status{package}}) {
1438 if (length($status{done}) and
1439 (not @sourceversions or not @{$status{fixed_versions}})) {
1454 =item bug -- scalar bug number
1456 =item sourceversion -- optional arrayref of source/version; overrides
1457 dist, arch, and version. [The entries in this array must be in the
1458 "source/version" format.] Eventually this can be used to for caching.
1462 Note: Currently the version information is cached; this needs to be
1463 changed before using this function in long lived programs.
1468 my %param = validate_with(params => \@_,
1469 spec => {bug => {type => SCALAR,
1472 sourceversions => {type => ARRAYREF,
1475 found => {type => ARRAYREF,
1478 fixed => {type => ARRAYREF,
1481 package => {type => SCALAR,
1483 version_cache => {type => HASHREF,
1488 # Resolve bugginess states (we might be looking at multiple
1489 # architectures, say). Found wins, then fixed, then absent.
1490 my $maxbuggy = 'absent';
1491 for my $package (split /\s*,\s*/, $param{package}) {
1492 for my $version (@{$param{sourceversions}}) {
1493 my $buggy = buggy(bug => $param{bug},
1494 version => $version,
1495 found => $param{found},
1496 fixed => $param{fixed},
1497 version_cache => $param{version_cache},
1498 package => $package,
1500 if ($buggy eq 'found') {
1502 } elsif ($buggy eq 'fixed') {
1503 $maxbuggy = 'fixed';
1520 Returns the output of Debbugs::Versions::buggy for a particular
1521 package, version and found/fixed set. Automatically turns found, fixed
1522 and version into source/version strings.
1524 Caching can be had by using the version_cache, but no attempt to check
1525 to see if the on disk information is more recent than the cache is
1526 made. [This will need to be fixed for long-lived processes.]
1531 my %param = validate_with(params => \@_,
1532 spec => {bug => {type => SCALAR,
1535 found => {type => ARRAYREF,
1538 fixed => {type => ARRAYREF,
1541 version_cache => {type => HASHREF,
1544 package => {type => SCALAR,
1546 version => {type => SCALAR,
1550 my @found = @{$param{found}};
1551 my @fixed = @{$param{fixed}};
1552 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1553 # We have non-source version versions
1554 @found = makesourceversions($param{package},undef,
1557 @fixed = makesourceversions($param{package},undef,
1561 if ($param{version} !~ m{/}) {
1562 my ($version) = makesourceversions($param{package},undef,
1565 $param{version} = $version if defined $version;
1567 # Figure out which source packages we need
1569 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1570 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1571 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1572 $param{version} =~ m{/};
1574 if (not defined $param{version_cache} or
1575 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1576 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1577 foreach my $source (keys %sources) {
1578 my $srchash = substr $source, 0, 1;
1579 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1580 if (not defined $version_fh) {
1581 # We only want to warn if it's a package which actually has a maintainer
1582 my $maints = getmaintainers();
1583 next if not exists $maints->{$source};
1584 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1587 $version->load($version_fh);
1589 if (defined $param{version_cache}) {
1590 $param{version_cache}{join(',',sort keys %sources)} = $version;
1594 $version = $param{version_cache}{join(',',sort keys %sources)};
1596 return $version->buggy($param{version},\@found,\@fixed);
1599 sub isstrongseverity {
1600 my $severity = shift;
1601 $severity = $config{default_severity} if
1602 not defined $severity or $severity eq '';
1603 return grep { $_ eq $severity } @{$config{strong_severities}};
1608 =head2 generate_index_db_line
1610 my $data = read_bug(bug => $bug,
1611 location => $initialdir);
1612 # generate_index_db_line hasn't been written yet at all.
1613 my $line = generate_index_db_line($data);
1615 Returns a line for a bug suitable to be written out to index.db.
1619 sub generate_index_db_line {
1620 my ($data,$bug) = @_;
1622 # just in case someone has given us a split out data
1623 $data = join_status_fields($data);
1625 my $whendone = "open";
1626 my $severity = $config{default_severity};
1627 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1628 $pkglist =~ s/^,+//;
1629 $pkglist =~ s/,+$//;
1630 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1631 $whendone = "done" if defined $data->{done} and length $data->{done};
1632 $severity = $data->{severity} if length $data->{severity};
1633 return sprintf "%s %d %d %s [%s] %s %s\n",
1634 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1635 $data->{originator}, $severity, $data->{keywords};
1640 =head1 PRIVATE FUNCTIONS
1644 sub update_realtime {
1645 my ($file, %bugs) = @_;
1647 # update realtime index.db
1649 return () unless keys %bugs;
1650 my $idx_old = IO::File->new($file,'r')
1651 or die "Couldn't open ${file}: $!";
1652 my $idx_new = IO::File->new($file.'.new','w')
1653 or die "Couldn't open ${file}.new: $!";
1655 binmode($idx_old,':raw:utf8');
1656 binmode($idx_new,':raw:encoding(UTF-8)');
1657 my $min_bug = min(keys %bugs);
1661 while($line = <$idx_old>) {
1662 @line = split /\s/, $line;
1663 # Two cases; replacing existing line or adding new line
1664 if (exists $bugs{$line[1]}) {
1665 my $new = $bugs{$line[1]};
1666 delete $bugs{$line[1]};
1667 $min_bug = min(keys %bugs);
1668 if ($new eq "NOCHANGE") {
1669 print {$idx_new} $line;
1670 $changed_bugs{$line[1]} = $line;
1671 } elsif ($new eq "REMOVE") {
1672 $changed_bugs{$line[1]} = $line;
1674 print {$idx_new} $new;
1675 $changed_bugs{$line[1]} = $line;
1679 while ($line[1] > $min_bug) {
1680 print {$idx_new} $bugs{$min_bug};
1681 delete $bugs{$min_bug};
1682 last unless keys %bugs;
1683 $min_bug = min(keys %bugs);
1685 print {$idx_new} $line;
1687 last unless keys %bugs;
1689 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1691 print {$idx_new} <$idx_old>;
1696 rename("$file.new", $file);
1698 return %changed_bugs;
1701 sub bughook_archive {
1703 filelock("$config{spool_dir}/debbugs.trace.lock");
1704 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1705 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1706 map{($_,'REMOVE')} @refs);
1707 update_realtime("$config{spool_dir}/index.archive.realtime",
1713 my ( $type, %bugs_temp ) = @_;
1714 filelock("$config{spool_dir}/debbugs.trace.lock");
1717 for my $bug (keys %bugs_temp) {
1718 my $data = $bugs_temp{$bug};
1719 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1721 $bugs{$bug} = generate_index_db_line($data,$bug);
1723 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);