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};
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};
297 =head2 split_status_fields
299 my @data = split_status_fields(@data);
301 Splits splittable status fields (like package, tags, blocks,
302 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
303 passed @data intact using dclone.
305 In scalar context, returns only the first element of @data.
309 our $ditch_empty = sub{
311 my $splitter = shift @t;
312 return grep {length $_} map {split $splitter} @t;
315 our $sort_and_unique = sub {
320 if ($all_numeric and $v =~ /\D/) {
323 next if exists $u{$v};
328 return sort {$a <=> $b} @v;
334 my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))};
336 (package => \&splitpackages,
337 affects => \&splitpackages,
338 blocks => $ditch_space_unique_and_sort,
339 blockedby => $ditch_space_unique_and_sort,
340 # this isn't strictly correct, but we'll split both of them for
341 # the time being until we ditch all use of keywords everywhere
343 keywords => $ditch_space_unique_and_sort,
344 tags => $ditch_space_unique_and_sort,
345 found_versions => $ditch_space_unique_and_sort,
346 fixed_versions => $ditch_space_unique_and_sort,
347 mergedwith => $ditch_space_unique_and_sort,
350 sub split_status_fields {
351 my @data = @{dclone(\@_)};
352 for my $data (@data) {
353 next if not defined $data;
354 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
355 not (ref($data) and ref($data) eq 'HASH');
356 for my $field (keys %{$data}) {
357 next unless defined $data->{$field};
358 if (exists $split_fields{$field}) {
359 next if ref($data->{$field});
361 if (ref($split_fields{$field}) eq 'CODE') {
362 @elements = &{$split_fields{$field}}($data->{$field});
364 elsif (not ref($split_fields{$field}) or
365 UNIVERSAL::isa($split_fields{$field},'Regex')
367 @elements = split $split_fields{$field}, $data->{$field};
369 $data->{$field} = \@elements;
373 return wantarray?@data:$data[0];
376 =head2 join_status_fields
378 my @data = join_status_fields(@data);
380 Handles joining the splitable status fields. (Basically, the inverse
381 of split_status_fields.
383 Primarily called from makestatus, but may be useful for other
384 functions after calling split_status_fields (or for legacy functions
385 if we transition to split fields by default).
389 sub join_status_fields {
396 found_versions => ' ',
397 fixed_versions => ' ',
402 my @data = @{dclone(\@_)};
403 for my $data (@data) {
404 next if not defined $data;
405 croak "Passed an element which is not a hashref to split_status_field: ".
407 if ref($data) ne 'HASH';
408 for my $field (keys %{$data}) {
409 next unless defined $data->{$field};
410 next unless ref($data->{$field}) eq 'ARRAY';
411 next unless exists $join_fields{$field};
412 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
415 return wantarray?@data:$data[0];
421 lockreadbug($bug_num,$location)
423 Performs a filelock, then reads the bug; the bug is unlocked if the
424 return is undefined, otherwise, you need to call unfilelock or
427 See readbug above for information on what this returns
432 my ($lref, $location) = @_;
433 return read_bug(bug => $lref, location => $location, lock => 1);
436 =head2 lockreadbugmerge
438 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
440 Performs a filelock, then reads the bug. If the bug is merged, locks
441 the merge lock. Returns a list of the number of locks and the bug
446 sub lockreadbugmerge {
447 my ($bug_num,$location) = @_;
448 my $data = lockreadbug(@_);
449 if (not defined $data) {
452 if (not length $data->{mergedwith}) {
456 filelock("$config{spool_dir}/lock/merge");
457 $data = lockreadbug(@_);
458 if (not defined $data) {
465 =head2 lock_read_all_merged_bugs
467 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
469 Performs a filelock, then reads the bug passed. If the bug is merged,
470 locks the merge lock, then reads and locks all of the other merged
471 bugs. Returns a list of the number of locks and the bug data for all
474 Will also return undef if any of the merged bugs failed to be read,
475 even if all of the others were read properly.
479 sub lock_read_all_merged_bugs {
480 my %param = validate_with(params => \@_,
481 spec => {bug => {type => SCALAR,
484 location => {type => SCALAR,
487 locks => {type => HASHREF,
493 my @data = read_bug(bug => $param{bug},
495 exists $param{location} ? (location => $param{location}):(),
496 exists $param{locks} ? (locks => $param{locks}):(),
498 if (not @data or not defined $data[0]) {
502 if (not length $data[0]->{mergedwith}) {
503 return ($locks,@data);
505 unfilelock(exists $param{locks}?$param{locks}:());
507 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
509 @data = read_bug(bug => $param{bug},
511 exists $param{location} ? (location => $param{location}):(),
512 exists $param{locks} ? (locks => $param{locks}):(),
514 if (not @data or not defined $data[0]) {
515 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
520 my @bugs = split / /, $data[0]->{mergedwith};
521 push @bugs, $param{bug};
522 for my $bug (@bugs) {
524 if ($bug != $param{bug}) {
526 read_bug(bug => $bug,
528 exists $param{location} ? (location => $param{location}):(),
529 exists $param{locks} ? (locks => $param{locks}):(),
531 if (not defined $newdata) {
533 unfilelock(exists $param{locks}?$param{locks}:());
536 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
541 # perform a sanity check to make sure that the merged bugs
542 # are all merged with eachother
543 # We do a cmp sort instead of an <=> sort here, because that's
545 my $expectmerge= join(' ',grep {$_ != $bug } sort @bugs);
546 if ($newdata->{mergedwith} ne $expectmerge) {
548 unfilelock(exists $param{locks}?$param{locks}:());
550 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
554 return ($locks,@data);
559 my $new_bug_num = new_bug(copy => $data->{bug_num});
561 Creates a new bug and returns the new bug number upon success.
569 validate_with(params => \@_,
570 spec => {copy => {type => SCALAR,
576 filelock("nextnumber.lock");
577 my $nn_fh = IO::File->new("nextnumber",'r') or
578 die "Unable to open nextnuber for reading: $!";
581 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
583 overwritefile("nextnumber",
586 my $nn_hash = get_hashname($nn);
588 my $c_hash = get_hashname($param{copy});
589 for my $file (qw(log status summary report)) {
590 copy("db-h/$c_hash/$param{copy}.$file",
591 "db-h/$nn_hash/${nn}.$file")
595 for my $file (qw(log status summary report)) {
596 overwritefile("db-h/$nn_hash/${nn}.$file",
601 # this probably needs to be munged to do something more elegant
602 # &bughook('new', $clone, $data);
609 my @v1fieldorder = qw(originator date subject msgid package
610 keywords done forwarded mergedwith severity);
614 my $content = makestatus($status,$version)
615 my $content = makestatus($status);
617 Creates the content for a status file based on the $status hashref
620 Really only useful for writebug
622 Currently defaults to version 2 (non-encoded rfc1522 names) but will
623 eventually default to version 3. If you care, you should specify a
629 my ($data,$version) = @_;
630 $version = 3 unless defined $version;
634 my %newdata = %$data;
635 for my $field (qw(found fixed)) {
636 if (exists $newdata{$field}) {
637 $newdata{"${field}_date"} =
638 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
641 %newdata = %{join_status_fields(\%newdata)};
643 %newdata = encode_utf8_structure(%newdata);
646 for my $field (@rfc1522_fields) {
647 $newdata{$field} = encode_rfc1522($newdata{$field});
651 # this is a bit of a hack; we should never, ever have \r or \n in
652 # the fields of status. Kill them off here. [Eventually, this
653 # should be superfluous.]
654 for my $field (keys %newdata) {
655 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
659 for my $field (@v1fieldorder) {
660 if (exists $newdata{$field} and defined $newdata{$field}) {
661 $contents .= "$newdata{$field}\n";
666 } elsif ($version == 2 or $version == 3) {
667 # Version 2 or 3. Add a file format version number for the sake of
668 # further extensibility in the future.
669 $contents .= "Format-Version: $version\n";
670 for my $field (keys %fields) {
671 if (exists $newdata{$field} and defined $newdata{$field}
672 and $newdata{$field} ne '') {
673 # Output field names in proper case, e.g. 'Merged-With'.
674 my $properfield = $fields{$field};
675 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
676 my $data = $newdata{$field};
677 $contents .= "$properfield: $data\n";
686 writebug($bug_num,$status,$location,$minversion,$disablebughook)
688 Writes the bug status and summary files out.
690 Skips writing out a status file if minversion is 2
692 Does not call bughook if disablebughook is true.
697 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
700 my %outputs = (1 => 'status', 3 => 'summary');
701 for my $version (keys %outputs) {
702 next if defined $minversion and $version < $minversion;
703 my $status = getbugcomponent($ref, $outputs{$version}, $location);
704 die "can't find location for $ref" unless defined $status;
707 open $sfh,">","$status.new" or
708 die "opening $status.new: $!";
711 open $sfh,">","$status.new" or
712 die "opening $status.new: $!";
714 print {$sfh} makestatus($data, $version) or
715 die "writing $status.new: $!";
716 close($sfh) or die "closing $status.new: $!";
722 rename("$status.new",$status) || die "installing new $status: $!";
725 # $disablebughook is a bit of a hack to let format migration scripts use
726 # this function rather than having to duplicate it themselves.
727 &bughook($change,$ref,$data) unless $disablebughook;
730 =head2 unlockwritebug
732 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
734 Writes a bug, then calls unfilelock; see writebug for what these
746 The following functions are exported with the :versions tag
748 =head2 addfoundversions
750 addfoundversions($status,$package,$version,$isbinary);
752 All use of this should be phased out in favor of Debbugs::Control::fixed/found
757 sub addfoundversions {
761 my $isbinary = shift;
762 return unless defined $version;
763 undef $package if defined $package and $package =~ m[(?:\s|/)];
764 my $source = $package;
765 if (defined $package and $package =~ s/^src://) {
770 if (defined $package and $isbinary) {
771 my @srcinfo = binary_to_source(binary => $package,
772 version => $version);
774 # We know the source package(s). Use a fully-qualified version.
775 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
778 # Otherwise, an unqualified version will have to do.
782 # Strip off various kinds of brain-damage.
784 $version =~ s/ *\(.*\)//;
785 $version =~ s/ +[A-Za-z].*//;
787 foreach my $ver (split /[,\s]+/, $version) {
788 my $sver = defined($source) ? "$source/$ver" : '';
789 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
790 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
792 @{$data->{fixed_versions}} =
793 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
797 =head2 removefoundversions
799 removefoundversions($data,$package,$versiontoremove)
801 Removes found versions from $data
803 If a version is fully qualified (contains /) only versions matching
804 exactly are removed. Otherwise, all versions matching the version
807 Currently $package and $isbinary are entirely ignored, but accepted
808 for backwards compatibility.
812 sub removefoundversions {
816 my $isbinary = shift;
817 return unless defined $version;
819 foreach my $ver (split /[,\s]+/, $version) {
821 # fully qualified version
822 @{$data->{found_versions}} =
824 @{$data->{found_versions}};
827 # non qualified version; delete all matchers
828 @{$data->{found_versions}} =
829 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
830 @{$data->{found_versions}};
836 sub addfixedversions {
840 my $isbinary = shift;
841 return unless defined $version;
842 undef $package if defined $package and $package =~ m[(?:\s|/)];
843 my $source = $package;
845 if (defined $package and $isbinary) {
846 my @srcinfo = binary_to_source(binary => $package,
847 version => $version);
849 # We know the source package(s). Use a fully-qualified version.
850 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
853 # Otherwise, an unqualified version will have to do.
857 # Strip off various kinds of brain-damage.
859 $version =~ s/ *\(.*\)//;
860 $version =~ s/ +[A-Za-z].*//;
862 foreach my $ver (split /[,\s]+/, $version) {
863 my $sver = defined($source) ? "$source/$ver" : '';
864 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
865 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
867 @{$data->{found_versions}} =
868 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
872 sub removefixedversions {
876 my $isbinary = shift;
877 return unless defined $version;
879 foreach my $ver (split /[,\s]+/, $version) {
881 # fully qualified version
882 @{$data->{fixed_versions}} =
884 @{$data->{fixed_versions}};
887 # non qualified version; delete all matchers
888 @{$data->{fixed_versions}} =
889 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
890 @{$data->{fixed_versions}};
901 Split a package string from the status file into a list of package names.
907 return unless defined $pkgs;
908 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
912 =head2 bug_archiveable
914 bug_archiveable(bug => $bug_num);
920 =item bug -- bug number (required)
922 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
924 =item version -- Debbugs::Version information (optional)
926 =item days_until -- return days until the bug can be archived
930 Returns 1 if the bug can be archived
931 Returns 0 if the bug cannot be archived
933 If days_until is true, returns the number of days until the bug can be
934 archived, -1 if it cannot be archived. 0 means that the bug can be
935 archived the next time the archiver runs.
937 Returns undef on failure.
941 # This will eventually need to be fixed before we start using mod_perl
942 our $version_cache = {};
944 my %param = validate_with(params => \@_,
945 spec => {bug => {type => SCALAR,
948 status => {type => HASHREF,
951 days_until => {type => BOOLEAN,
954 ignore_time => {type => BOOLEAN,
959 # This is what we return if the bug cannot be archived.
960 my $cannot_archive = $param{days_until}?-1:0;
961 # read the status information
962 my $status = $param{status};
963 if (not exists $param{status} or not defined $status) {
964 $status = read_bug(bug=>$param{bug});
965 if (not defined $status) {
966 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
970 # Bugs can be archived if they are
972 if (not defined $status->{done} or not length $status->{done}) {
973 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
974 return $cannot_archive
976 # Check to make sure that the bug has none of the unremovable tags set
977 if (@{$config{removal_unremovable_tags}}) {
978 for my $tag (split ' ', ($status->{keywords}||'')) {
979 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
980 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
981 return $cannot_archive;
986 # If we just are checking if the bug can be archived, we'll not even bother
987 # checking the versioning information if the bug has been -done for less than 28 days.
988 my $log_file = getbugcomponent($param{bug},'log');
989 if (not defined $log_file) {
990 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
991 return $cannot_archive;
993 my $max_log_age = max(map {$config{remove_age} - -M $_}
994 $log_file, map {my $log = getbugcomponent($_,'log');
995 defined $log ? ($log) : ();
997 split / /, $status->{mergedwith}
999 if (not $param{days_until} and not $param{ignore_time}
1000 and $max_log_age > 0
1002 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
1003 return $cannot_archive;
1005 # At this point, we have to get the versioning information for this bug.
1006 # We examine the set of distribution tags. If a bug has no distribution
1007 # tags set, we assume a default set, otherwise we use the tags the bug
1010 # In cases where we are assuming a default set, if the severity
1011 # is strong, we use the strong severity default; otherwise, we
1012 # use the normal default.
1014 # There must be fixed_versions for us to look at the versioning
1016 my $min_fixed_time = time;
1017 my $min_archive_days = 0;
1018 if (@{$status->{fixed_versions}}) {
1020 @dist_tags{@{$config{removal_distribution_tags}}} =
1021 (1) x @{$config{removal_distribution_tags}};
1023 for my $tag (split ' ', ($status->{keywords}||'')) {
1024 next unless exists $config{distribution_aliases}{$tag};
1025 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1026 $dists{$config{distribution_aliases}{$tag}} = 1;
1028 if (not keys %dists) {
1029 if (isstrongseverity($status->{severity})) {
1030 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1031 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1034 @dists{@{$config{removal_default_distribution_tags}}} =
1035 (1) x @{$config{removal_default_distribution_tags}};
1038 my %source_versions;
1039 my @sourceversions = get_versions(package => $status->{package},
1040 dist => [keys %dists],
1043 @source_versions{@sourceversions} = (1) x @sourceversions;
1044 # If the bug has not been fixed in the versions actually
1045 # distributed, then it cannot be archived.
1046 if ('found' eq max_buggy(bug => $param{bug},
1047 sourceversions => [keys %source_versions],
1048 found => $status->{found_versions},
1049 fixed => $status->{fixed_versions},
1050 version_cache => $version_cache,
1051 package => $status->{package},
1053 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1054 return $cannot_archive;
1056 # Since the bug has at least been fixed in the architectures
1057 # that matters, we check to see how long it has been fixed.
1059 # If $param{ignore_time}, then we should ignore time.
1060 if ($param{ignore_time}) {
1061 return $param{days_until}?0:1;
1064 # To do this, we order the times from most recent to oldest;
1065 # when we come to the first found version, we stop.
1066 # If we run out of versions, we only report the time of the
1068 my %time_versions = get_versions(package => $status->{package},
1069 dist => [keys %dists],
1073 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1074 my $buggy = buggy(bug => $param{bug},
1075 version => $version,
1076 found => $status->{found_versions},
1077 fixed => $status->{fixed_versions},
1078 version_cache => $version_cache,
1079 package => $status->{package},
1081 last if $buggy eq 'found';
1082 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1084 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1085 # if there are no versions in the archive at all, then
1086 # we can archive if enough days have passed
1089 # If $param{ignore_time}, then we should ignore time.
1090 if ($param{ignore_time}) {
1091 return $param{days_until}?0:1;
1093 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1094 my $age = ceil($max_log_age);
1095 if ($age > 0 or $min_archive_days > 0) {
1096 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1097 return $param{days_until}?max($age,$min_archive_days):0;
1100 return $param{days_until}?0:1;
1105 =head2 get_bug_status
1107 my $status = get_bug_status(bug => $nnn);
1109 my $status = get_bug_status($bug_num)
1115 =item bug -- scalar bug number
1117 =item status -- optional hashref of bug status as returned by readbug
1118 (can be passed to avoid rereading the bug information)
1120 =item bug_index -- optional tied index of bug status infomration;
1121 currently not correctly implemented.
1123 =item version -- optional version(s) to check package status at
1125 =item dist -- optional distribution(s) to check package status at
1127 =item arch -- optional architecture(s) to check package status at
1129 =item bugusertags -- optional hashref of bugusertags
1131 =item sourceversion -- optional arrayref of source/version; overrides
1132 dist, arch, and version. [The entries in this array must be in the
1133 "source/version" format.] Eventually this can be used to for caching.
1135 =item indicatesource -- if true, indicate which source packages this
1136 bug could belong to (or does belong to in the case of bugs assigned to
1137 a source package). Defaults to true.
1141 Note: Currently the version information is cached; this needs to be
1142 changed before using this function in long lived programs.
1146 Currently returns a hashref of status with the following keys.
1150 =item id -- bug number
1152 =item bug_num -- duplicate of id
1154 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1156 =item tags -- duplicate of keywords
1158 =item package -- name of package that the bug is assigned to
1160 =item severity -- severity of the bug
1162 =item pending -- pending state of the bug; one of following possible
1163 values; values listed later have precedence if multiple conditions are
1168 =item pending -- default state
1170 =item forwarded -- bug has been forwarded
1172 =item pending-fixed -- bug is tagged pending
1174 =item fixed -- bug is tagged fixed
1176 =item absent -- bug does not apply to this distribution/architecture
1178 =item done -- bug is resolved in this distribution/architecture
1182 =item location -- db-h or archive; the location in the filesystem
1184 =item subject -- title of the bug
1186 =item last_modified -- epoch that the bug was last modified
1188 =item date -- epoch that the bug was filed
1190 =item originator -- bug reporter
1192 =item log_modified -- epoch that the log file was last modified
1194 =item msgid -- Message id of the original bug report
1199 Other key/value pairs are returned but are not currently documented here.
1203 sub get_bug_status {
1207 my %param = validate_with(params => \@_,
1208 spec => {bug => {type => SCALAR,
1211 status => {type => HASHREF,
1214 bug_index => {type => OBJECT,
1217 version => {type => SCALAR|ARRAYREF,
1220 dist => {type => SCALAR|ARRAYREF,
1223 arch => {type => SCALAR|ARRAYREF,
1226 bugusertags => {type => HASHREF,
1229 sourceversions => {type => ARRAYREF,
1232 indicatesource => {type => BOOLEAN,
1239 if (defined $param{bug_index} and
1240 exists $param{bug_index}{$param{bug}}) {
1241 %status = %{ $param{bug_index}{$param{bug}} };
1242 $status{pending} = $status{ status };
1243 $status{id} = $param{bug};
1246 if (defined $param{status}) {
1247 %status = %{$param{status}};
1250 my $location = getbuglocation($param{bug}, 'summary');
1251 return {} if not defined $location or not length $location;
1252 %status = %{ readbug( $param{bug}, $location ) };
1254 $status{id} = $param{bug};
1256 if (defined $param{bugusertags}{$param{bug}}) {
1257 $status{keywords} = "" unless defined $status{keywords};
1258 $status{keywords} .= " " unless $status{keywords} eq "";
1259 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1261 $status{tags} = $status{keywords};
1262 my %tags = map { $_ => 1 } split ' ', $status{tags};
1264 $status{package} = '' if not defined $status{package};
1265 $status{"package"} =~ s/\s*$//;
1267 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1271 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1272 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1274 $status{"pending"} = 'pending';
1275 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1276 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1277 $status{"pending"} = 'fixed' if ($tags{fixed});
1280 my $presence = bug_presence(status => \%status,
1281 map{(exists $param{$_})?($_,$param{$_}):()}
1282 qw(bug sourceversions arch dist version found fixed package)
1284 if (defined $presence) {
1285 if ($presence eq 'fixed') {
1286 $status{pending} = 'done';
1288 elsif ($presence eq 'absent') {
1289 $status{pending} = 'absent';
1297 my $precence = bug_presence(bug => nnn,
1301 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1302 is found, absent, fixed, or no information is available in the
1303 distribution (dist) and/or architecture (arch) specified.
1310 =item bug -- scalar bug number
1312 =item status -- optional hashref of bug status as returned by readbug
1313 (can be passed to avoid rereading the bug information)
1315 =item bug_index -- optional tied index of bug status infomration;
1316 currently not correctly implemented.
1318 =item version -- optional version to check package status at
1320 =item dist -- optional distribution to check package status at
1322 =item arch -- optional architecture to check package status at
1324 =item sourceversion -- optional arrayref of source/version; overrides
1325 dist, arch, and version. [The entries in this array must be in the
1326 "source/version" format.] Eventually this can be used to for caching.
1333 my %param = validate_with(params => \@_,
1334 spec => {bug => {type => SCALAR,
1337 status => {type => HASHREF,
1340 version => {type => SCALAR|ARRAYREF,
1343 dist => {type => SCALAR|ARRAYREF,
1346 arch => {type => SCALAR|ARRAYREF,
1349 sourceversions => {type => ARRAYREF,
1355 if (defined $param{status}) {
1356 %status = %{$param{status}};
1359 my $location = getbuglocation($param{bug}, 'summary');
1360 return {} if not length $location;
1361 %status = %{ readbug( $param{bug}, $location ) };
1365 my $pseudo_desc = getpseudodesc();
1366 if (not exists $param{sourceversions}) {
1368 # pseudopackages do not have source versions by definition.
1369 if (exists $pseudo_desc->{$status{package}}) {
1372 elsif (defined $param{version}) {
1373 foreach my $arch (make_list($param{arch})) {
1374 for my $package (split /\s*,\s*/, $status{package}) {
1375 my @temp = makesourceversions($package,
1377 make_list($param{version})
1379 @sourceversions{@temp} = (1) x @temp;
1382 } elsif (defined $param{dist}) {
1383 my %affects_distribution_tags;
1384 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1385 (1) x @{$config{affects_distribution_tags}};
1386 my $some_distributions_disallowed = 0;
1387 my %allowed_distributions;
1388 for my $tag (split ' ', ($status{keywords}||'')) {
1389 if (exists $config{distribution_aliases}{$tag} and
1390 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1391 $some_distributions_disallowed = 1;
1392 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1394 elsif (exists $affects_distribution_tags{$tag}) {
1395 $some_distributions_disallowed = 1;
1396 $allowed_distributions{$tag} = 1;
1399 my @archs = make_list(exists $param{arch}?$param{arch}:());
1400 GET_SOURCE_VERSIONS:
1401 foreach my $arch (@archs) {
1402 for my $package (split /\s*,\s*/, $status{package}) {
1405 if ($package =~ /^src:(.+)$/) {
1409 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1410 # if some distributions are disallowed,
1411 # and this isn't an allowed
1412 # distribution, then we ignore this
1413 # distribution for the purposees of
1415 if ($some_distributions_disallowed and
1416 not exists $allowed_distributions{$dist}) {
1419 push @versions, get_versions(package => $package,
1421 ($source?(arch => 'source'):
1422 (defined $arch?(arch => $arch):())),
1425 next unless @versions;
1426 my @temp = make_source_versions(package => $package,
1428 versions => \@versions,
1430 @sourceversions{@temp} = (1) x @temp;
1433 # this should really be split out into a subroutine,
1434 # but it'd touch so many things currently, that we fake
1435 # it; it's needed to properly handle bugs which are
1436 # erroneously assigned to the binary package, and we'll
1437 # probably have it go away eventually.
1438 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1440 goto GET_SOURCE_VERSIONS;
1444 # TODO: This should probably be handled further out for efficiency and
1445 # for more ease of distinguishing between pkg= and src= queries.
1446 # DLA: src= queries should just pass arch=source, and they'll be happy.
1447 @sourceversions = keys %sourceversions;
1450 @sourceversions = @{$param{sourceversions}};
1452 my $maxbuggy = 'undef';
1453 if (@sourceversions) {
1454 $maxbuggy = max_buggy(bug => $param{bug},
1455 sourceversions => \@sourceversions,
1456 found => $status{found_versions},
1457 fixed => $status{fixed_versions},
1458 package => $status{package},
1459 version_cache => $version_cache,
1462 elsif (defined $param{dist} and
1463 not exists $pseudo_desc->{$status{package}}) {
1466 if (length($status{done}) and
1467 (not @sourceversions or not @{$status{fixed_versions}})) {
1482 =item bug -- scalar bug number
1484 =item sourceversion -- optional arrayref of source/version; overrides
1485 dist, arch, and version. [The entries in this array must be in the
1486 "source/version" format.] Eventually this can be used to for caching.
1490 Note: Currently the version information is cached; this needs to be
1491 changed before using this function in long lived programs.
1496 my %param = validate_with(params => \@_,
1497 spec => {bug => {type => SCALAR,
1500 sourceversions => {type => ARRAYREF,
1503 found => {type => ARRAYREF,
1506 fixed => {type => ARRAYREF,
1509 package => {type => SCALAR,
1511 version_cache => {type => HASHREF,
1516 # Resolve bugginess states (we might be looking at multiple
1517 # architectures, say). Found wins, then fixed, then absent.
1518 my $maxbuggy = 'absent';
1519 for my $package (split /\s*,\s*/, $param{package}) {
1520 for my $version (@{$param{sourceversions}}) {
1521 my $buggy = buggy(bug => $param{bug},
1522 version => $version,
1523 found => $param{found},
1524 fixed => $param{fixed},
1525 version_cache => $param{version_cache},
1526 package => $package,
1528 if ($buggy eq 'found') {
1530 } elsif ($buggy eq 'fixed') {
1531 $maxbuggy = 'fixed';
1548 Returns the output of Debbugs::Versions::buggy for a particular
1549 package, version and found/fixed set. Automatically turns found, fixed
1550 and version into source/version strings.
1552 Caching can be had by using the version_cache, but no attempt to check
1553 to see if the on disk information is more recent than the cache is
1554 made. [This will need to be fixed for long-lived processes.]
1559 my %param = validate_with(params => \@_,
1560 spec => {bug => {type => SCALAR,
1563 found => {type => ARRAYREF,
1566 fixed => {type => ARRAYREF,
1569 version_cache => {type => HASHREF,
1572 package => {type => SCALAR,
1574 version => {type => SCALAR,
1578 my @found = @{$param{found}};
1579 my @fixed = @{$param{fixed}};
1580 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1581 # We have non-source version versions
1582 @found = makesourceversions($param{package},undef,
1585 @fixed = makesourceversions($param{package},undef,
1589 if ($param{version} !~ m{/}) {
1590 my ($version) = makesourceversions($param{package},undef,
1593 $param{version} = $version if defined $version;
1595 # Figure out which source packages we need
1597 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1598 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1599 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1600 $param{version} =~ m{/};
1602 if (not defined $param{version_cache} or
1603 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1604 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1605 foreach my $source (keys %sources) {
1606 my $srchash = substr $source, 0, 1;
1607 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1608 if (not defined $version_fh) {
1609 # We only want to warn if it's a package which actually has a maintainer
1610 my $maints = getmaintainers();
1611 next if not exists $maints->{$source};
1612 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1615 $version->load($version_fh);
1617 if (defined $param{version_cache}) {
1618 $param{version_cache}{join(',',sort keys %sources)} = $version;
1622 $version = $param{version_cache}{join(',',sort keys %sources)};
1624 return $version->buggy($param{version},\@found,\@fixed);
1627 sub isstrongseverity {
1628 my $severity = shift;
1629 $severity = $config{default_severity} if
1630 not defined $severity or $severity eq '';
1631 return grep { $_ eq $severity } @{$config{strong_severities}};
1636 =head2 generate_index_db_line
1638 my $data = read_bug(bug => $bug,
1639 location => $initialdir);
1640 # generate_index_db_line hasn't been written yet at all.
1641 my $line = generate_index_db_line($data);
1643 Returns a line for a bug suitable to be written out to index.db.
1647 sub generate_index_db_line {
1648 my ($data,$bug) = @_;
1650 # just in case someone has given us a split out data
1651 $data = join_status_fields($data);
1653 my $whendone = "open";
1654 my $severity = $config{default_severity};
1655 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1656 $pkglist =~ s/^,+//;
1657 $pkglist =~ s/,+$//;
1658 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1659 $whendone = "done" if defined $data->{done} and length $data->{done};
1660 $severity = $data->{severity} if length $data->{severity};
1661 return sprintf "%s %d %d %s [%s] %s %s\n",
1662 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1663 $data->{originator}, $severity, $data->{keywords};
1668 =head1 PRIVATE FUNCTIONS
1672 sub update_realtime {
1673 my ($file, %bugs) = @_;
1675 # update realtime index.db
1677 return () unless keys %bugs;
1678 my $idx_old = IO::File->new($file,'r')
1679 or die "Couldn't open ${file}: $!";
1680 my $idx_new = IO::File->new($file.'.new','w')
1681 or die "Couldn't open ${file}.new: $!";
1683 binmode($idx_old,':raw:utf8');
1684 binmode($idx_new,':raw:encoding(UTF-8)');
1685 my $min_bug = min(keys %bugs);
1689 while($line = <$idx_old>) {
1690 @line = split /\s/, $line;
1691 # Two cases; replacing existing line or adding new line
1692 if (exists $bugs{$line[1]}) {
1693 my $new = $bugs{$line[1]};
1694 delete $bugs{$line[1]};
1695 $min_bug = min(keys %bugs);
1696 if ($new eq "NOCHANGE") {
1697 print {$idx_new} $line;
1698 $changed_bugs{$line[1]} = $line;
1699 } elsif ($new eq "REMOVE") {
1700 $changed_bugs{$line[1]} = $line;
1702 print {$idx_new} $new;
1703 $changed_bugs{$line[1]} = $line;
1707 while ($line[1] > $min_bug) {
1708 print {$idx_new} $bugs{$min_bug};
1709 delete $bugs{$min_bug};
1710 last unless keys %bugs;
1711 $min_bug = min(keys %bugs);
1713 print {$idx_new} $line;
1715 last unless keys %bugs;
1717 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1719 print {$idx_new} <$idx_old>;
1724 rename("$file.new", $file);
1726 return %changed_bugs;
1729 sub bughook_archive {
1731 filelock("$config{spool_dir}/debbugs.trace.lock");
1732 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1733 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1734 map{($_,'REMOVE')} @refs);
1735 update_realtime("$config{spool_dir}/index.archive.realtime",
1741 my ( $type, %bugs_temp ) = @_;
1742 filelock("$config{spool_dir}/debbugs.trace.lock");
1745 for my $bug (keys %bugs_temp) {
1746 my $data = $bugs_temp{$bug};
1747 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1749 $bugs{$bug} = generate_index_db_line($data,$bug);
1751 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);