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
38 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
39 use Exporter qw(import);
41 use Params::Validate qw(validate_with :types);
42 use Debbugs::Common qw(:util :lock :quit :misc);
44 use Debbugs::Config qw(:config);
45 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
46 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
47 use Debbugs::Versions;
48 use Debbugs::Versions::Dpkg;
50 use File::Copy qw(copy);
51 use Encode qw(decode encode is_utf8);
53 use Storable qw(dclone);
54 use List::AllUtils qw(min max uniq);
55 use DateTime::Format::Pg;
61 $DEBUG = 0 unless defined $DEBUG;
64 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
65 qw(isstrongseverity bug_presence split_status_fields),
68 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
69 qw(lock_read_all_merged_bugs),
71 write => [qw(writebug makestatus unlockwritebug)],
73 versions => [qw(addfoundversions addfixedversions),
74 qw(removefoundversions removefixedversions)
76 hook => [qw(bughook bughook_archive)],
77 indexdb => [qw(generate_index_db_line)],
78 fields => [qw(%fields)],
81 Exporter::export_ok_tags(keys %EXPORT_TAGS);
82 $EXPORT_TAGS{all} = [@EXPORT_OK];
88 readbug($bug_num,$location)
91 Reads a summary file from the archive given a bug number and a bug
92 location. Valid locations are those understood by L</getbugcomponent>
96 # these probably shouldn't be imported by most people, but
97 # Debbugs::Control needs them, so they're now exportable
98 our %fields = (originator => 'submitter',
100 subject => 'subject',
101 msgid => 'message-id',
102 'package' => 'package',
105 forwarded => 'forwarded-to',
106 mergedwith => 'merged-with',
107 severity => 'severity',
109 found_versions => 'found-in',
110 found_date => 'found-date',
111 fixed_versions => 'fixed-in',
112 fixed_date => 'fixed-date',
114 blockedby => 'blocked-by',
115 unarchived => 'unarchived',
116 summary => 'summary',
117 outlook => 'outlook',
118 affects => 'affects',
122 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
123 my @rfc1522_fields = qw(originator subject done forwarded owner);
126 return read_bug(bug => $_[0],
127 (@_ > 1)?(location => $_[1]):()
133 read_bug(bug => $bug_num,
134 location => 'archive',
136 read_bug(summary => 'path/to/bugnum.summary');
139 A more complete function than readbug; it enables you to pass a full
140 path to the summary file instead of the bug number and/or location.
146 =item bug -- the bug number
148 =item location -- optional location which is passed to getbugcomponent
150 =item summary -- complete path to the .summary file which will be read
152 =item lock -- whether to obtain a lock for the bug to prevent
153 something modifying it while the bug has been read. You B<must> call
154 C<unfilelock();> if something not undef is returned from read_bug.
156 =item locks -- hashref of already obtained locks; incremented as new
157 locks are needed, and decremented as locks are released on particular
162 One of C<bug> or C<summary> must be passed. This function will return
163 undef on failure, and will die if improper arguments are passed.
172 {bug => {type => SCALAR,
174 # something really stupid passes negative bugnumbers
177 location => {type => SCALAR|UNDEF,
180 summary => {type => SCALAR,
183 lock => {type => BOOLEAN,
186 locks => {type => HASHREF,
190 my %param = validate_with(params => \@_,
193 die "One of bug or summary must be passed to read_bug"
194 if not exists $param{bug} and not exists $param{summary};
199 if (not defined $param{summary}) {
201 ($lref,$location) = @param{qw(bug location)};
202 if (not defined $location) {
203 $location = getbuglocation($lref,'summary');
204 return undef if not defined $location;
206 $status = getbugcomponent($lref, 'summary', $location);
207 $log = getbugcomponent($lref, 'log' , $location);
208 $report = getbugcomponent($lref, 'report' , $location);
209 return undef unless defined $status;
210 return undef if not -e $status;
213 $status = $param{summary};
216 $log =~ s/\.summary$/.log/;
217 $report =~ s/\.summary$/.report/;
218 ($location) = $status =~ m/(db-h|db|archive)/;
219 ($param{bug}) = $status =~ m/(\d+)\.summary$/;
222 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
224 my $status_fh = IO::File->new($status, 'r');
225 if (not defined $status_fh) {
226 warn "Unable to open $status for reading: $!";
228 unfilelock(exists $param{locks}?$param{locks}:());
232 binmode($status_fh,':encoding(UTF-8)');
239 while (<$status_fh>) {
242 if (not defined $version and
243 /^Format-Version: ([0-9]+)/i
248 $version = 2 if not defined $version;
249 # Version 3 is the latest format version currently supported.
251 warn "Unsupported status version '$version'";
253 unfilelock(exists $param{locks}?$param{locks}:());
258 state $namemap = {reverse %fields};
259 for my $line (@lines) {
260 if ($line =~ /(\S+?): (.*)/) {
261 my ($name, $value) = (lc $1, $2);
262 # this is a bit of a hack; we should never, ever have \r
263 # or \n in the fields of status. Kill them off here.
264 # [Eventually, this should be superfluous.]
265 $value =~ s/[\r\n]//g;
266 $data{$namemap->{$name}} = $value if exists $namemap->{$name};
269 for my $field (keys %fields) {
270 $data{$field} = '' unless exists $data{$field};
273 for my $field (@rfc1522_fields) {
274 $data{$field} = decode_rfc1522($data{$field});
277 $data{severity} = $config{default_severity} if $data{severity} eq '';
278 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
279 $data{$field} = [split ' ', $data{$field}];
281 for my $field (qw(found fixed)) {
282 # create the found/fixed hashes which indicate when a
283 # particular version was marked found or marked fixed.
284 @{$data{$field}}{@{$data{"${field}_versions"}}} =
285 (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}),
286 @{$data{"${field}_date"}});
289 my $status_modified = (stat($status))[9];
290 # Add log last modified time
291 $data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9];
292 my $report_modified = (stat($report))[9] // $data{log_modified};
293 $data{last_modified} = max($status_modified,$data{log_modified});
294 # if the date isn't set (ancient bug), use the smallest of any of the modified
295 if (not defined $data{date} or not length($data{date})) {
296 $data{date} = min($report_modified,$status_modified,$data{log_modified});
298 $data{location} = $location;
299 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
300 $data{bug_num} = $param{bug};
302 # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
303 # and not include this bug
304 if (defined $data{mergedwith} and
308 grep { $_ != $data{bug_num}}
310 split / /, $data{mergedwith}
316 =head2 split_status_fields
318 my @data = split_status_fields(@data);
320 Splits splittable status fields (like package, tags, blocks,
321 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
322 passed @data intact using dclone.
324 In scalar context, returns only the first element of @data.
328 our $ditch_empty = sub{
330 my $splitter = shift @t;
331 return grep {length $_} map {split $splitter} @t;
334 our $sort_and_unique = sub {
339 if ($all_numeric and $v =~ /\D/) {
342 next if exists $u{$v};
347 return sort {$a <=> $b} @v;
353 my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))};
355 (package => \&splitpackages,
356 affects => \&splitpackages,
357 # Ideally we won't have to split source, but because some consumers of
358 # get_bug_status cannot handle arrayref, we will split it here.
359 source => \&splitpackages,
360 blocks => $ditch_space_unique_and_sort,
361 blockedby => $ditch_space_unique_and_sort,
362 # this isn't strictly correct, but we'll split both of them for
363 # the time being until we ditch all use of keywords everywhere
365 keywords => $ditch_space_unique_and_sort,
366 tags => $ditch_space_unique_and_sort,
367 found_versions => $ditch_space_unique_and_sort,
368 fixed_versions => $ditch_space_unique_and_sort,
369 mergedwith => $ditch_space_unique_and_sort,
372 sub split_status_fields {
373 my @data = @{dclone(\@_)};
374 for my $data (@data) {
375 next if not defined $data;
376 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
377 not (ref($data) and ref($data) eq 'HASH');
378 for my $field (keys %{$data}) {
379 next unless defined $data->{$field};
380 if (exists $split_fields{$field}) {
381 next if ref($data->{$field});
383 if (ref($split_fields{$field}) eq 'CODE') {
384 @elements = &{$split_fields{$field}}($data->{$field});
386 elsif (not ref($split_fields{$field}) or
387 UNIVERSAL::isa($split_fields{$field},'Regex')
389 @elements = split $split_fields{$field}, $data->{$field};
391 $data->{$field} = \@elements;
395 return wantarray?@data:$data[0];
398 =head2 join_status_fields
400 my @data = join_status_fields(@data);
402 Handles joining the splitable status fields. (Basically, the inverse
403 of split_status_fields.
405 Primarily called from makestatus, but may be useful for other
406 functions after calling split_status_fields (or for legacy functions
407 if we transition to split fields by default).
411 sub join_status_fields {
418 found_versions => ' ',
419 fixed_versions => ' ',
424 my @data = @{dclone(\@_)};
425 for my $data (@data) {
426 next if not defined $data;
427 croak "Passed an element which is not a hashref to split_status_field: ".
429 if ref($data) ne 'HASH';
430 for my $field (keys %{$data}) {
431 next unless defined $data->{$field};
432 next unless ref($data->{$field}) eq 'ARRAY';
433 next unless exists $join_fields{$field};
434 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
437 return wantarray?@data:$data[0];
443 lockreadbug($bug_num,$location)
445 Performs a filelock, then reads the bug; the bug is unlocked if the
446 return is undefined, otherwise, you need to call unfilelock or
449 See readbug above for information on what this returns
454 my ($lref, $location) = @_;
455 return read_bug(bug => $lref, location => $location, lock => 1);
458 =head2 lockreadbugmerge
460 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
462 Performs a filelock, then reads the bug. If the bug is merged, locks
463 the merge lock. Returns a list of the number of locks and the bug
468 sub lockreadbugmerge {
469 my $data = lockreadbug(@_);
470 if (not defined $data) {
473 if (not length $data->{mergedwith}) {
477 filelock("$config{spool_dir}/lock/merge");
478 $data = lockreadbug(@_);
479 if (not defined $data) {
486 =head2 lock_read_all_merged_bugs
488 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
490 Performs a filelock, then reads the bug passed. If the bug is merged,
491 locks the merge lock, then reads and locks all of the other merged
492 bugs. Returns a list of the number of locks and the bug data for all
495 Will also return undef if any of the merged bugs failed to be read,
496 even if all of the others were read properly.
500 sub lock_read_all_merged_bugs {
501 my %param = validate_with(params => \@_,
502 spec => {bug => {type => SCALAR,
505 location => {type => SCALAR,
508 locks => {type => HASHREF,
514 my @data = read_bug(bug => $param{bug},
516 exists $param{location} ? (location => $param{location}):(),
517 exists $param{locks} ? (locks => $param{locks}):(),
519 if (not @data or not defined $data[0]) {
523 if (not length $data[0]->{mergedwith}) {
524 return ($locks,@data);
526 unfilelock(exists $param{locks}?$param{locks}:());
528 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
530 @data = read_bug(bug => $param{bug},
532 exists $param{location} ? (location => $param{location}):(),
533 exists $param{locks} ? (locks => $param{locks}):(),
535 if (not @data or not defined $data[0]) {
536 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
541 my @bugs = split / /, $data[0]->{mergedwith};
542 push @bugs, $param{bug};
543 for my $bug (@bugs) {
545 if ($bug != $param{bug}) {
547 read_bug(bug => $bug,
549 exists $param{location} ? (location => $param{location}):(),
550 exists $param{locks} ? (locks => $param{locks}):(),
552 if (not defined $newdata) {
554 unfilelock(exists $param{locks}?$param{locks}:());
557 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
562 # perform a sanity check to make sure that the merged bugs
563 # are all merged with eachother
564 # We do a cmp sort instead of an <=> sort here, because that's
567 join(' ',grep {$_ != $bug }
570 if ($newdata->{mergedwith} ne $expectmerge) {
572 unfilelock(exists $param{locks}?$param{locks}:());
574 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
578 return ($locks,@data);
583 my $new_bug_num = new_bug(copy => $data->{bug_num});
585 Creates a new bug and returns the new bug number upon success.
593 validate_with(params => \@_,
594 spec => {copy => {type => SCALAR,
600 filelock("nextnumber.lock");
601 my $nn_fh = IO::File->new("nextnumber",'r') or
602 die "Unable to open nextnuber for reading: $!";
605 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
607 overwritefile("nextnumber",
610 my $nn_hash = get_hashname($nn);
612 my $c_hash = get_hashname($param{copy});
613 for my $file (qw(log status summary report)) {
614 copy("db-h/$c_hash/$param{copy}.$file",
615 "db-h/$nn_hash/${nn}.$file")
619 for my $file (qw(log status summary report)) {
620 overwritefile("db-h/$nn_hash/${nn}.$file",
625 # this probably needs to be munged to do something more elegant
626 # &bughook('new', $clone, $data);
633 my @v1fieldorder = qw(originator date subject msgid package
634 keywords done forwarded mergedwith severity);
638 my $content = makestatus($status,$version)
639 my $content = makestatus($status);
641 Creates the content for a status file based on the $status hashref
644 Really only useful for writebug
646 Currently defaults to version 2 (non-encoded rfc1522 names) but will
647 eventually default to version 3. If you care, you should specify a
653 my ($data,$version) = @_;
654 $version = 3 unless defined $version;
658 my %newdata = %$data;
659 for my $field (qw(found fixed)) {
660 if (exists $newdata{$field}) {
661 $newdata{"${field}_date"} =
662 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
665 %newdata = %{join_status_fields(\%newdata)};
667 %newdata = encode_utf8_structure(%newdata);
670 for my $field (@rfc1522_fields) {
671 $newdata{$field} = encode_rfc1522($newdata{$field});
675 # this is a bit of a hack; we should never, ever have \r or \n in
676 # the fields of status. Kill them off here. [Eventually, this
677 # should be superfluous.]
678 for my $field (keys %newdata) {
679 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
683 for my $field (@v1fieldorder) {
684 if (exists $newdata{$field} and defined $newdata{$field}) {
685 $contents .= "$newdata{$field}\n";
690 } elsif ($version == 2 or $version == 3) {
691 # Version 2 or 3. Add a file format version number for the sake of
692 # further extensibility in the future.
693 $contents .= "Format-Version: $version\n";
694 for my $field (keys %fields) {
695 if (exists $newdata{$field} and defined $newdata{$field}
696 and $newdata{$field} ne '') {
697 # Output field names in proper case, e.g. 'Merged-With'.
698 my $properfield = $fields{$field};
699 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
700 my $data = $newdata{$field};
701 $contents .= "$properfield: $data\n";
710 writebug($bug_num,$status,$location,$minversion,$disablebughook)
712 Writes the bug status and summary files out.
714 Skips writing out a status file if minversion is 2
716 Does not call bughook if disablebughook is true.
721 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
724 my %outputs = (1 => 'status', 3 => 'summary');
725 for my $version (keys %outputs) {
726 next if defined $minversion and $version < $minversion;
727 my $status = getbugcomponent($ref, $outputs{$version}, $location);
728 die "can't find location for $ref" unless defined $status;
731 open $sfh,">","$status.new" or
732 die "opening $status.new: $!";
735 open $sfh,">","$status.new" or
736 die "opening $status.new: $!";
738 print {$sfh} makestatus($data, $version) or
739 die "writing $status.new: $!";
740 close($sfh) or die "closing $status.new: $!";
746 rename("$status.new",$status) || die "installing new $status: $!";
749 # $disablebughook is a bit of a hack to let format migration scripts use
750 # this function rather than having to duplicate it themselves.
751 &bughook($change,$ref,$data) unless $disablebughook;
754 =head2 unlockwritebug
756 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
758 Writes a bug, then calls unfilelock; see writebug for what these
770 The following functions are exported with the :versions tag
772 =head2 addfoundversions
774 addfoundversions($status,$package,$version,$isbinary);
776 All use of this should be phased out in favor of Debbugs::Control::fixed/found
781 sub addfoundversions {
785 my $isbinary = shift;
786 return unless defined $version;
787 undef $package if defined $package and $package =~ m[(?:\s|/)];
788 my $source = $package;
789 if (defined $package and $package =~ s/^src://) {
794 if (defined $package and $isbinary) {
795 my @srcinfo = binary_to_source(binary => $package,
796 version => $version);
798 # We know the source package(s). Use a fully-qualified version.
799 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
802 # Otherwise, an unqualified version will have to do.
806 # Strip off various kinds of brain-damage.
808 $version =~ s/ *\(.*\)//;
809 $version =~ s/ +[A-Za-z].*//;
811 foreach my $ver (split /[,\s]+/, $version) {
812 my $sver = defined($source) ? "$source/$ver" : '';
813 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
814 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
816 @{$data->{fixed_versions}} =
817 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
821 =head2 removefoundversions
823 removefoundversions($data,$package,$versiontoremove)
825 Removes found versions from $data
827 If a version is fully qualified (contains /) only versions matching
828 exactly are removed. Otherwise, all versions matching the version
831 Currently $package and $isbinary are entirely ignored, but accepted
832 for backwards compatibility.
836 sub removefoundversions {
840 my $isbinary = shift;
841 return unless defined $version;
843 foreach my $ver (split /[,\s]+/, $version) {
845 # fully qualified version
846 @{$data->{found_versions}} =
848 @{$data->{found_versions}};
851 # non qualified version; delete all matchers
852 @{$data->{found_versions}} =
853 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
854 @{$data->{found_versions}};
860 sub addfixedversions {
864 my $isbinary = shift;
865 return unless defined $version;
866 undef $package if defined $package and $package =~ m[(?:\s|/)];
867 my $source = $package;
869 if (defined $package and $isbinary) {
870 my @srcinfo = binary_to_source(binary => $package,
871 version => $version);
873 # We know the source package(s). Use a fully-qualified version.
874 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
877 # Otherwise, an unqualified version will have to do.
881 # Strip off various kinds of brain-damage.
883 $version =~ s/ *\(.*\)//;
884 $version =~ s/ +[A-Za-z].*//;
886 foreach my $ver (split /[,\s]+/, $version) {
887 my $sver = defined($source) ? "$source/$ver" : '';
888 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
889 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
891 @{$data->{found_versions}} =
892 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
896 sub removefixedversions {
900 my $isbinary = shift;
901 return unless defined $version;
903 foreach my $ver (split /[,\s]+/, $version) {
905 # fully qualified version
906 @{$data->{fixed_versions}} =
908 @{$data->{fixed_versions}};
911 # non qualified version; delete all matchers
912 @{$data->{fixed_versions}} =
913 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
914 @{$data->{fixed_versions}};
925 Split a package string from the status file into a list of package names.
931 return unless defined $pkgs;
932 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
936 =head2 bug_archiveable
938 bug_archiveable(bug => $bug_num);
944 =item bug -- bug number (required)
946 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
948 =item version -- Debbugs::Version information (optional)
950 =item days_until -- return days until the bug can be archived
954 Returns 1 if the bug can be archived
955 Returns 0 if the bug cannot be archived
957 If days_until is true, returns the number of days until the bug can be
958 archived, -1 if it cannot be archived. 0 means that the bug can be
959 archived the next time the archiver runs.
961 Returns undef on failure.
965 # This will eventually need to be fixed before we start using mod_perl
966 our $version_cache = {};
968 my %param = validate_with(params => \@_,
969 spec => {bug => {type => SCALAR,
972 status => {type => HASHREF,
975 days_until => {type => BOOLEAN,
978 ignore_time => {type => BOOLEAN,
983 # This is what we return if the bug cannot be archived.
984 my $cannot_archive = $param{days_until}?-1:0;
985 # read the status information
986 my $status = $param{status};
987 if (not exists $param{status} or not defined $status) {
988 $status = read_bug(bug=>$param{bug});
989 if (not defined $status) {
990 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
994 # Bugs can be archived if they are
996 if (not defined $status->{done} or not length $status->{done}) {
997 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
998 return $cannot_archive
1000 # Check to make sure that the bug has none of the unremovable tags set
1001 if (@{$config{removal_unremovable_tags}}) {
1002 for my $tag (split ' ', ($status->{keywords}||'')) {
1003 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
1004 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
1005 return $cannot_archive;
1010 # If we just are checking if the bug can be archived, we'll not even bother
1011 # checking the versioning information if the bug has been -done for less than 28 days.
1012 my $log_file = getbugcomponent($param{bug},'log');
1013 if (not defined $log_file or not -e $log_file) {
1014 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
1015 return $cannot_archive;
1017 my @log_files = $log_file, (map {my $log = getbugcomponent($_,'log');
1018 defined $log ? ($log) : ();
1020 split / /, $status->{mergedwith});
1021 my $max_log_age = max(map {-e $_?($config{remove_age} - -M _):0}
1023 if (not $param{days_until} and not $param{ignore_time}
1024 and $max_log_age > 0
1026 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
1027 return $cannot_archive;
1029 # At this point, we have to get the versioning information for this bug.
1030 # We examine the set of distribution tags. If a bug has no distribution
1031 # tags set, we assume a default set, otherwise we use the tags the bug
1034 # In cases where we are assuming a default set, if the severity
1035 # is strong, we use the strong severity default; otherwise, we
1036 # use the normal default.
1038 # There must be fixed_versions for us to look at the versioning
1040 my $min_fixed_time = time;
1041 my $min_archive_days = 0;
1042 if (@{$status->{fixed_versions}}) {
1044 @dist_tags{@{$config{removal_distribution_tags}}} =
1045 (1) x @{$config{removal_distribution_tags}};
1047 for my $tag (split ' ', ($status->{keywords}||'')) {
1048 next unless exists $config{distribution_aliases}{$tag};
1049 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1050 $dists{$config{distribution_aliases}{$tag}} = 1;
1052 if (not keys %dists) {
1053 if (isstrongseverity($status->{severity})) {
1054 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1055 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1058 @dists{@{$config{removal_default_distribution_tags}}} =
1059 (1) x @{$config{removal_default_distribution_tags}};
1062 my %source_versions;
1063 my @sourceversions = get_versions(package => $status->{package},
1064 dist => [keys %dists],
1067 @source_versions{@sourceversions} = (1) x @sourceversions;
1068 # If the bug has not been fixed in the versions actually
1069 # distributed, then it cannot be archived.
1070 if ('found' eq max_buggy(bug => $param{bug},
1071 sourceversions => [keys %source_versions],
1072 found => $status->{found_versions},
1073 fixed => $status->{fixed_versions},
1074 version_cache => $version_cache,
1075 package => $status->{package},
1077 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1078 return $cannot_archive;
1080 # Since the bug has at least been fixed in the architectures
1081 # that matters, we check to see how long it has been fixed.
1083 # If $param{ignore_time}, then we should ignore time.
1084 if ($param{ignore_time}) {
1085 return $param{days_until}?0:1;
1088 # To do this, we order the times from most recent to oldest;
1089 # when we come to the first found version, we stop.
1090 # If we run out of versions, we only report the time of the
1092 my %time_versions = get_versions(package => $status->{package},
1093 dist => [keys %dists],
1097 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1098 my $buggy = buggy(bug => $param{bug},
1099 version => $version,
1100 found => $status->{found_versions},
1101 fixed => $status->{fixed_versions},
1102 version_cache => $version_cache,
1103 package => $status->{package},
1105 last if $buggy eq 'found';
1106 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1108 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1109 # if there are no versions in the archive at all, then
1110 # we can archive if enough days have passed
1113 # If $param{ignore_time}, then we should ignore time.
1114 if ($param{ignore_time}) {
1115 return $param{days_until}?0:1;
1117 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1118 my $age = ceil($max_log_age);
1119 if ($age > 0 or $min_archive_days > 0) {
1120 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1121 return $param{days_until}?max($age,$min_archive_days):0;
1124 return $param{days_until}?0:1;
1129 =head2 get_bug_status
1131 my $status = get_bug_status(bug => $nnn);
1133 my $status = get_bug_status($bug_num)
1139 =item bug -- scalar bug number
1141 =item status -- optional hashref of bug status as returned by readbug
1142 (can be passed to avoid rereading the bug information)
1144 =item bug_index -- optional tied index of bug status infomration;
1145 currently not correctly implemented.
1147 =item version -- optional version(s) to check package status at
1149 =item dist -- optional distribution(s) to check package status at
1151 =item arch -- optional architecture(s) to check package status at
1153 =item bugusertags -- optional hashref of bugusertags
1155 =item sourceversion -- optional arrayref of source/version; overrides
1156 dist, arch, and version. [The entries in this array must be in the
1157 "source/version" format.] Eventually this can be used to for caching.
1159 =item indicatesource -- if true, indicate which source packages this
1160 bug could belong to (or does belong to in the case of bugs assigned to
1161 a source package). Defaults to true.
1165 Note: Currently the version information is cached; this needs to be
1166 changed before using this function in long lived programs.
1170 Currently returns a hashref of status with the following keys.
1174 =item id -- bug number
1176 =item bug_num -- duplicate of id
1178 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1180 =item tags -- duplicate of keywords
1182 =item package -- name of package that the bug is assigned to
1184 =item severity -- severity of the bug
1186 =item pending -- pending state of the bug; one of following possible
1187 values; values listed later have precedence if multiple conditions are
1192 =item pending -- default state
1194 =item forwarded -- bug has been forwarded
1196 =item pending-fixed -- bug is tagged pending
1198 =item fixed -- bug is tagged fixed
1200 =item absent -- bug does not apply to this distribution/architecture
1202 =item done -- bug is resolved in this distribution/architecture
1206 =item location -- db-h or archive; the location in the filesystem
1208 =item subject -- title of the bug
1210 =item last_modified -- epoch that the bug was last modified
1212 =item date -- epoch that the bug was filed
1214 =item originator -- bug reporter
1216 =item log_modified -- epoch that the log file was last modified
1218 =item msgid -- Message id of the original bug report
1223 Other key/value pairs are returned but are not currently documented here.
1227 sub get_bug_status {
1232 {bug => {type => SCALAR,
1235 status => {type => HASHREF,
1238 bug_index => {type => OBJECT,
1241 version => {type => SCALAR|ARRAYREF,
1244 dist => {type => SCALAR|ARRAYREF,
1247 arch => {type => SCALAR|ARRAYREF,
1250 bugusertags => {type => HASHREF,
1253 sourceversions => {type => ARRAYREF,
1256 indicatesource => {type => BOOLEAN,
1259 binary_to_source_cache => {type => HASHREF,
1262 schema => {type => OBJECT,
1266 my %param = validate_with(params => \@_,
1271 if (defined $param{bug_index} and
1272 exists $param{bug_index}{$param{bug}}) {
1273 %status = %{ $param{bug_index}{$param{bug}} };
1274 $status{pending} = $status{ status };
1275 $status{id} = $param{bug};
1278 my $statuses = get_bug_statuses(@_);
1279 if (exists $statuses->{$param{bug}}) {
1280 return $statuses->{$param{bug}};
1286 sub get_bug_statuses {
1288 {bug => {type => SCALAR|ARRAYREF,
1290 status => {type => HASHREF,
1293 bug_index => {type => OBJECT,
1296 version => {type => SCALAR|ARRAYREF,
1299 dist => {type => SCALAR|ARRAYREF,
1302 arch => {type => SCALAR|ARRAYREF,
1305 bugusertags => {type => HASHREF,
1308 sourceversions => {type => ARRAYREF,
1311 indicatesource => {type => BOOLEAN,
1314 binary_to_source_cache => {type => HASHREF,
1317 schema => {type => OBJECT,
1321 my %param = validate_with(params => \@_,
1324 my $bin_to_src_cache = {};
1325 if (defined $param{binary_to_source_cache}) {
1326 $bin_to_src_cache = $param{binary_to_source_cache};
1330 if (defined $param{schema}) {
1332 $param{schema}->resultset('BugStatus')->
1333 search_rs({id => [make_list($param{bug})]},
1334 {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->
1336 for my $bug_status (@bug_statuses) {
1337 $statuses{$bug_status->{bug_num}} =
1339 for my $field (qw(blocks blockedby done),
1342 $bug_status->{$field} //='';
1344 $bug_status->{keywords} =
1345 $bug_status->{tags};
1346 $bug_status->{location} = $bug_status->{archived}?'archive':'db-h';
1347 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
1348 $bug_status->{$field} = [split ' ', $bug_status->{$field} // ''];
1350 for my $field (qw(found fixed)) {
1351 # create the found/fixed hashes which indicate when a
1352 # particular version was marked found or marked fixed.
1353 @{$bug_status->{$field}}{@{$bug_status->{"${field}_versions"}}} =
1354 (('') x (@{$bug_status->{"${field}_versions"}} -
1355 @{$bug_status->{"${field}_date"}}),
1356 @{$bug_status->{"${field}_date"}});
1358 $bug_status->{id} = $bug_status->{bug_num};
1361 for my $bug (make_list($param{bug})) {
1362 if (defined $param{bug_index} and
1363 exists $param{bug_index}{$bug}) {
1364 my %status = %{$param{bug_index}{$bug}};
1365 $status{pending} = $status{status};
1367 $statuses{$bug} = \%status;
1369 elsif (defined $param{status} and
1370 $param{status}{bug_num} == $bug
1372 $statuses{$bug} = {%{$param{status}}};
1374 my $location = getbuglocation($bug, 'summary');
1375 next if not defined $location or not length $location;
1376 my %status = %{ readbug( $bug, $location ) };
1378 $statuses{$bug} = \%status;
1382 for my $bug (keys %statuses) {
1383 my $status = $statuses{$bug};
1385 if (defined $param{bugusertags}{$param{bug}}) {
1386 $status->{keywords} = "" unless defined $status->{keywords};
1387 $status->{keywords} .= " " unless $status->{keywords} eq "";
1388 $status->{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1390 $status->{tags} = $status->{keywords};
1391 my %tags = map { $_ => 1 } split ' ', $status->{tags};
1393 $status->{package} = '' if not defined $status->{package};
1394 $status->{"package"} =~ s/\s*$//;
1396 $status->{source} = binary_to_source(binary=>[split /\s*,\s*/, $status->{package}],
1398 cache => $bin_to_src_cache,
1399 defined $param{schema}?
1400 (schema => $param{schema}):(),
1403 $status->{"package"} = 'unknown' if ($status->{"package"} eq '');
1404 $status->{"severity"} = 'normal' if (not defined $status->{severity} or $status->{"severity"} eq '');
1406 $status->{"pending"} = 'pending';
1407 $status->{"pending"} = 'forwarded' if (length($status->{"forwarded"}));
1408 $status->{"pending"} = 'pending-fixed' if ($tags{pending});
1409 $status->{"pending"} = 'fixed' if ($tags{fixed});
1412 my $presence = bug_presence(status => $status,
1414 map{(exists $param{$_})?($_,$param{$_}):()}
1415 qw(sourceversions arch dist version found fixed package)
1417 if (defined $presence) {
1418 if ($presence eq 'fixed') {
1419 $status->{pending} = 'done';
1420 } elsif ($presence eq 'absent') {
1421 $status->{pending} = 'absent';
1430 my $precence = bug_presence(bug => nnn,
1434 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1435 is found, absent, fixed, or no information is available in the
1436 distribution (dist) and/or architecture (arch) specified.
1443 =item bug -- scalar bug number
1445 =item status -- optional hashref of bug status as returned by readbug
1446 (can be passed to avoid rereading the bug information)
1448 =item bug_index -- optional tied index of bug status infomration;
1449 currently not correctly implemented.
1451 =item version -- optional version to check package status at
1453 =item dist -- optional distribution to check package status at
1455 =item arch -- optional architecture to check package status at
1457 =item sourceversion -- optional arrayref of source/version; overrides
1458 dist, arch, and version. [The entries in this array must be in the
1459 "source/version" format.] Eventually this can be used to for caching.
1466 my %param = validate_with(params => \@_,
1467 spec => {bug => {type => SCALAR,
1470 status => {type => HASHREF,
1473 version => {type => SCALAR|ARRAYREF,
1476 dist => {type => SCALAR|ARRAYREF,
1479 arch => {type => SCALAR|ARRAYREF,
1482 sourceversions => {type => ARRAYREF,
1488 if (defined $param{status}) {
1489 %status = %{$param{status}};
1492 my $location = getbuglocation($param{bug}, 'summary');
1493 return {} if not length $location;
1494 %status = %{ readbug( $param{bug}, $location ) };
1498 my $pseudo_desc = getpseudodesc();
1499 if (not exists $param{sourceversions}) {
1501 # pseudopackages do not have source versions by definition.
1502 if (exists $pseudo_desc->{$status{package}}) {
1505 elsif (defined $param{version}) {
1506 foreach my $arch (make_list($param{arch})) {
1507 for my $package (split /\s*,\s*/, $status{package}) {
1508 my @temp = makesourceversions($package,
1510 make_list($param{version})
1512 @sourceversions{@temp} = (1) x @temp;
1515 } elsif (defined $param{dist}) {
1516 my %affects_distribution_tags;
1517 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1518 (1) x @{$config{affects_distribution_tags}};
1519 my $some_distributions_disallowed = 0;
1520 my %allowed_distributions;
1521 for my $tag (split ' ', ($status{keywords}||'')) {
1522 if (exists $config{distribution_aliases}{$tag} and
1523 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1524 $some_distributions_disallowed = 1;
1525 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1527 elsif (exists $affects_distribution_tags{$tag}) {
1528 $some_distributions_disallowed = 1;
1529 $allowed_distributions{$tag} = 1;
1532 my @archs = make_list(exists $param{arch}?$param{arch}:());
1533 GET_SOURCE_VERSIONS:
1534 foreach my $arch (@archs) {
1535 for my $package (split /\s*,\s*/, $status{package}) {
1538 if ($package =~ /^src:(.+)$/) {
1542 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1543 # if some distributions are disallowed,
1544 # and this isn't an allowed
1545 # distribution, then we ignore this
1546 # distribution for the purposees of
1548 if ($some_distributions_disallowed and
1549 not exists $allowed_distributions{$dist}) {
1552 push @versions, get_versions(package => $package,
1554 ($source?(arch => 'source'):
1555 (defined $arch?(arch => $arch):())),
1558 next unless @versions;
1559 my @temp = make_source_versions(package => $package,
1561 versions => \@versions,
1563 @sourceversions{@temp} = (1) x @temp;
1566 # this should really be split out into a subroutine,
1567 # but it'd touch so many things currently, that we fake
1568 # it; it's needed to properly handle bugs which are
1569 # erroneously assigned to the binary package, and we'll
1570 # probably have it go away eventually.
1571 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1573 goto GET_SOURCE_VERSIONS;
1577 # TODO: This should probably be handled further out for efficiency and
1578 # for more ease of distinguishing between pkg= and src= queries.
1579 # DLA: src= queries should just pass arch=source, and they'll be happy.
1580 @sourceversions = keys %sourceversions;
1583 @sourceversions = @{$param{sourceversions}};
1585 my $maxbuggy = 'undef';
1586 if (@sourceversions) {
1587 $maxbuggy = max_buggy(bug => $param{bug},
1588 sourceversions => \@sourceversions,
1589 found => $status{found_versions},
1590 fixed => $status{fixed_versions},
1591 package => $status{package},
1592 version_cache => $version_cache,
1595 elsif (defined $param{dist} and
1596 not exists $pseudo_desc->{$status{package}}) {
1599 if (length($status{done}) and
1600 (not @sourceversions or not @{$status{fixed_versions}})) {
1615 =item bug -- scalar bug number
1617 =item sourceversion -- optional arrayref of source/version; overrides
1618 dist, arch, and version. [The entries in this array must be in the
1619 "source/version" format.] Eventually this can be used to for caching.
1623 Note: Currently the version information is cached; this needs to be
1624 changed before using this function in long lived programs.
1629 my %param = validate_with(params => \@_,
1630 spec => {bug => {type => SCALAR,
1633 sourceversions => {type => ARRAYREF,
1636 found => {type => ARRAYREF,
1639 fixed => {type => ARRAYREF,
1642 package => {type => SCALAR,
1644 version_cache => {type => HASHREF,
1649 # Resolve bugginess states (we might be looking at multiple
1650 # architectures, say). Found wins, then fixed, then absent.
1651 my $maxbuggy = 'absent';
1652 for my $package (split /\s*,\s*/, $param{package}) {
1653 for my $version (@{$param{sourceversions}}) {
1654 my $buggy = buggy(bug => $param{bug},
1655 version => $version,
1656 found => $param{found},
1657 fixed => $param{fixed},
1658 version_cache => $param{version_cache},
1659 package => $package,
1661 if ($buggy eq 'found') {
1663 } elsif ($buggy eq 'fixed') {
1664 $maxbuggy = 'fixed';
1681 Returns the output of Debbugs::Versions::buggy for a particular
1682 package, version and found/fixed set. Automatically turns found, fixed
1683 and version into source/version strings.
1685 Caching can be had by using the version_cache, but no attempt to check
1686 to see if the on disk information is more recent than the cache is
1687 made. [This will need to be fixed for long-lived processes.]
1692 my %param = validate_with(params => \@_,
1693 spec => {bug => {type => SCALAR,
1696 found => {type => ARRAYREF,
1699 fixed => {type => ARRAYREF,
1702 version_cache => {type => HASHREF,
1705 package => {type => SCALAR,
1707 version => {type => SCALAR,
1711 my @found = @{$param{found}};
1712 my @fixed = @{$param{fixed}};
1713 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1714 # We have non-source version versions
1715 @found = makesourceversions($param{package},undef,
1718 @fixed = makesourceversions($param{package},undef,
1722 if ($param{version} !~ m{/}) {
1723 my ($version) = makesourceversions($param{package},undef,
1726 $param{version} = $version if defined $version;
1728 # Figure out which source packages we need
1730 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1731 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1732 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1733 $param{version} =~ m{/};
1735 if (not defined $param{version_cache} or
1736 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1737 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1738 foreach my $source (keys %sources) {
1739 my $srchash = substr $source, 0, 1;
1740 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1741 if (not defined $version_fh) {
1742 # We only want to warn if it's a package which actually has a maintainer
1743 my $maints = getmaintainers();
1744 next if not exists $maints->{$source};
1745 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1748 $version->load($version_fh);
1750 if (defined $param{version_cache}) {
1751 $param{version_cache}{join(',',sort keys %sources)} = $version;
1755 $version = $param{version_cache}{join(',',sort keys %sources)};
1757 return $version->buggy($param{version},\@found,\@fixed);
1760 sub isstrongseverity {
1761 my $severity = shift;
1762 $severity = $config{default_severity} if
1763 not defined $severity or $severity eq '';
1764 return grep { $_ eq $severity } @{$config{strong_severities}};
1769 =head2 generate_index_db_line
1771 my $data = read_bug(bug => $bug,
1772 location => $initialdir);
1773 # generate_index_db_line hasn't been written yet at all.
1774 my $line = generate_index_db_line($data);
1776 Returns a line for a bug suitable to be written out to index.db.
1780 sub generate_index_db_line {
1781 my ($data,$bug) = @_;
1783 # just in case someone has given us a split out data
1784 $data = join_status_fields($data);
1786 my $whendone = "open";
1787 my $severity = $config{default_severity};
1788 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1789 $pkglist =~ s/^,+//;
1790 $pkglist =~ s/,+$//;
1791 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1792 $whendone = "done" if defined $data->{done} and length $data->{done};
1793 $severity = $data->{severity} if length $data->{severity};
1794 return sprintf "%s %d %d %s [%s] %s %s\n",
1795 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1796 $data->{originator}, $severity, $data->{keywords};
1801 =head1 PRIVATE FUNCTIONS
1805 sub update_realtime {
1806 my ($file, %bugs) = @_;
1808 # update realtime index.db
1810 return () unless keys %bugs;
1811 my $idx_old = IO::File->new($file,'r')
1812 or die "Couldn't open ${file}: $!";
1813 my $idx_new = IO::File->new($file.'.new','w')
1814 or die "Couldn't open ${file}.new: $!";
1816 binmode($idx_old,':raw:utf8');
1817 binmode($idx_new,':raw:encoding(UTF-8)');
1818 my $min_bug = min(keys %bugs);
1822 while($line = <$idx_old>) {
1823 @line = split /\s/, $line;
1824 # Two cases; replacing existing line or adding new line
1825 if (exists $bugs{$line[1]}) {
1826 my $new = $bugs{$line[1]};
1827 delete $bugs{$line[1]};
1828 $min_bug = min(keys %bugs);
1829 if ($new eq "NOCHANGE") {
1830 print {$idx_new} $line;
1831 $changed_bugs{$line[1]} = $line;
1832 } elsif ($new eq "REMOVE") {
1833 $changed_bugs{$line[1]} = $line;
1835 print {$idx_new} $new;
1836 $changed_bugs{$line[1]} = $line;
1840 while ($line[1] > $min_bug) {
1841 print {$idx_new} $bugs{$min_bug};
1842 delete $bugs{$min_bug};
1843 last unless keys %bugs;
1844 $min_bug = min(keys %bugs);
1846 print {$idx_new} $line;
1848 last unless keys %bugs;
1850 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1852 print {$idx_new} <$idx_old>;
1857 rename("$file.new", $file);
1859 return %changed_bugs;
1862 sub bughook_archive {
1864 filelock("$config{spool_dir}/debbugs.trace.lock");
1865 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1866 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1867 map{($_,'REMOVE')} @refs);
1868 update_realtime("$config{spool_dir}/index.archive.realtime",
1874 my ( $type, %bugs_temp ) = @_;
1875 filelock("$config{spool_dir}/debbugs.trace.lock");
1878 for my $bug (keys %bugs_temp) {
1879 my $data = $bugs_temp{$bug};
1880 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1882 $bugs{$bug} = generate_index_db_line($data,$bug);
1884 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);