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),
67 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
68 qw(lock_read_all_merged_bugs),
70 write => [qw(writebug makestatus unlockwritebug)],
72 versions => [qw(addfoundversions addfixedversions),
73 qw(removefoundversions removefixedversions)
75 hook => [qw(bughook bughook_archive)],
76 indexdb => [qw(generate_index_db_line)],
77 fields => [qw(%fields)],
80 Exporter::export_ok_tags(keys %EXPORT_TAGS);
81 $EXPORT_TAGS{all} = [@EXPORT_OK];
87 readbug($bug_num,$location)
90 Reads a summary file from the archive given a bug number and a bug
91 location. Valid locations are those understood by L</getbugcomponent>
95 # these probably shouldn't be imported by most people, but
96 # Debbugs::Control needs them, so they're now exportable
97 our %fields = (originator => 'submitter',
100 msgid => 'message-id',
101 'package' => 'package',
104 forwarded => 'forwarded-to',
105 mergedwith => 'merged-with',
106 severity => 'severity',
108 found_versions => 'found-in',
109 found_date => 'found-date',
110 fixed_versions => 'fixed-in',
111 fixed_date => 'fixed-date',
113 blockedby => 'blocked-by',
114 unarchived => 'unarchived',
115 summary => 'summary',
116 outlook => 'outlook',
117 affects => 'affects',
121 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
122 my @rfc1522_fields = qw(originator subject done forwarded owner);
125 return read_bug(bug => $_[0],
126 (@_ > 1)?(location => $_[1]):()
132 read_bug(bug => $bug_num,
133 location => 'archive',
135 read_bug(summary => 'path/to/bugnum.summary');
138 A more complete function than readbug; it enables you to pass a full
139 path to the summary file instead of the bug number and/or location.
145 =item bug -- the bug number
147 =item location -- optional location which is passed to getbugcomponent
149 =item summary -- complete path to the .summary file which will be read
151 =item lock -- whether to obtain a lock for the bug to prevent
152 something modifying it while the bug has been read. You B<must> call
153 C<unfilelock();> if something not undef is returned from read_bug.
155 =item locks -- hashref of already obtained locks; incremented as new
156 locks are needed, and decremented as locks are released on particular
161 One of C<bug> or C<summary> must be passed. This function will return
162 undef on failure, and will die if improper arguments are passed.
171 {bug => {type => SCALAR,
173 # something really stupid passes negative bugnumbers
176 location => {type => SCALAR|UNDEF,
179 summary => {type => SCALAR,
182 lock => {type => BOOLEAN,
185 locks => {type => HASHREF,
189 my %param = validate_with(params => \@_,
192 die "One of bug or summary must be passed to read_bug"
193 if not exists $param{bug} and not exists $param{summary};
198 if (not defined $param{summary}) {
200 ($lref,$location) = @param{qw(bug location)};
201 if (not defined $location) {
202 $location = getbuglocation($lref,'summary');
203 return undef if not defined $location;
205 $status = getbugcomponent($lref, 'summary', $location);
206 $log = getbugcomponent($lref, 'log' , $location);
207 $report = getbugcomponent($lref, 'report' , $location);
208 return undef unless defined $status;
209 return undef if not -e $status;
212 $status = $param{summary};
215 $log =~ s/\.summary$/.log/;
216 $report =~ s/\.summary$/.report/;
217 ($location) = $status =~ m/(db-h|db|archive)/;
218 ($param{bug}) = $status =~ m/(\d+)\.summary$/;
221 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
223 my $status_fh = IO::File->new($status, 'r');
224 if (not defined $status_fh) {
225 warn "Unable to open $status for reading: $!";
227 unfilelock(exists $param{locks}?$param{locks}:());
231 binmode($status_fh,':encoding(UTF-8)');
238 while (<$status_fh>) {
241 if (not defined $version and
242 /^Format-Version: ([0-9]+)/i
247 $version = 2 if not defined $version;
248 # Version 3 is the latest format version currently supported.
250 warn "Unsupported status version '$version'";
252 unfilelock(exists $param{locks}?$param{locks}:());
257 state $namemap = {reverse %fields};
258 for my $line (@lines) {
259 if ($line =~ /(\S+?): (.*)/) {
260 my ($name, $value) = (lc $1, $2);
261 # this is a bit of a hack; we should never, ever have \r
262 # or \n in the fields of status. Kill them off here.
263 # [Eventually, this should be superfluous.]
264 $value =~ s/[\r\n]//g;
265 $data{$namemap->{$name}} = $value if exists $namemap->{$name};
268 for my $field (keys %fields) {
269 $data{$field} = '' unless exists $data{$field};
272 for my $field (@rfc1522_fields) {
273 $data{$field} = decode_rfc1522($data{$field});
276 $data{severity} = $config{default_severity} if $data{severity} eq '';
277 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
278 $data{$field} = [split ' ', $data{$field}];
280 for my $field (qw(found fixed)) {
281 # create the found/fixed hashes which indicate when a
282 # particular version was marked found or marked fixed.
283 @{$data{$field}}{@{$data{"${field}_versions"}}} =
284 (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}),
285 @{$data{"${field}_date"}});
288 my $status_modified = (stat($status))[9];
289 # Add log last modified time
290 $data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9];
291 my $report_modified = (stat($report))[9] // $data{log_modified};
292 $data{last_modified} = max($status_modified,$data{log_modified});
293 # if the date isn't set (ancient bug), use the smallest of any of the modified
294 if (not defined $data{date} or not length($data{date})) {
295 $data{date} = min($report_modified,$status_modified,$data{log_modified});
297 $data{location} = $location;
298 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
299 $data{bug_num} = $param{bug};
301 # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
302 # and not include this bug
303 if (defined $data{mergedwith} and
307 grep { $_ != $data{bug_num}}
309 split / /, $data{mergedwith}
315 =head2 split_status_fields
317 my @data = split_status_fields(@data);
319 Splits splittable status fields (like package, tags, blocks,
320 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
321 passed @data intact using dclone.
323 In scalar context, returns only the first element of @data.
327 our $ditch_empty = sub{
329 my $splitter = shift @t;
330 return grep {length $_} map {split $splitter} @t;
333 our $sort_and_unique = sub {
338 if ($all_numeric and $v =~ /\D/) {
341 next if exists $u{$v};
346 return sort {$a <=> $b} @v;
352 my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))};
354 (package => \&splitpackages,
355 affects => \&splitpackages,
356 # Ideally we won't have to split source, but because some consumers of
357 # get_bug_status cannot handle arrayref, we will split it here.
358 source => \&splitpackages,
359 blocks => $ditch_space_unique_and_sort,
360 blockedby => $ditch_space_unique_and_sort,
361 # this isn't strictly correct, but we'll split both of them for
362 # the time being until we ditch all use of keywords everywhere
364 keywords => $ditch_space_unique_and_sort,
365 tags => $ditch_space_unique_and_sort,
366 found_versions => $ditch_space_unique_and_sort,
367 fixed_versions => $ditch_space_unique_and_sort,
368 mergedwith => $ditch_space_unique_and_sort,
371 sub split_status_fields {
372 my @data = @{dclone(\@_)};
373 for my $data (@data) {
374 next if not defined $data;
375 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
376 not (ref($data) and ref($data) eq 'HASH');
377 for my $field (keys %{$data}) {
378 next unless defined $data->{$field};
379 if (exists $split_fields{$field}) {
380 next if ref($data->{$field});
382 if (ref($split_fields{$field}) eq 'CODE') {
383 @elements = &{$split_fields{$field}}($data->{$field});
385 elsif (not ref($split_fields{$field}) or
386 UNIVERSAL::isa($split_fields{$field},'Regex')
388 @elements = split $split_fields{$field}, $data->{$field};
390 $data->{$field} = \@elements;
394 return wantarray?@data:$data[0];
397 =head2 join_status_fields
399 my @data = join_status_fields(@data);
401 Handles joining the splitable status fields. (Basically, the inverse
402 of split_status_fields.
404 Primarily called from makestatus, but may be useful for other
405 functions after calling split_status_fields (or for legacy functions
406 if we transition to split fields by default).
410 sub join_status_fields {
417 found_versions => ' ',
418 fixed_versions => ' ',
423 my @data = @{dclone(\@_)};
424 for my $data (@data) {
425 next if not defined $data;
426 croak "Passed an element which is not a hashref to split_status_field: ".
428 if ref($data) ne 'HASH';
429 for my $field (keys %{$data}) {
430 next unless defined $data->{$field};
431 next unless ref($data->{$field}) eq 'ARRAY';
432 next unless exists $join_fields{$field};
433 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
436 return wantarray?@data:$data[0];
442 lockreadbug($bug_num,$location)
444 Performs a filelock, then reads the bug; the bug is unlocked if the
445 return is undefined, otherwise, you need to call unfilelock or
448 See readbug above for information on what this returns
453 my ($lref, $location) = @_;
454 return read_bug(bug => $lref, location => $location, lock => 1);
457 =head2 lockreadbugmerge
459 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
461 Performs a filelock, then reads the bug. If the bug is merged, locks
462 the merge lock. Returns a list of the number of locks and the bug
467 sub lockreadbugmerge {
468 my $data = lockreadbug(@_);
469 if (not defined $data) {
472 if (not length $data->{mergedwith}) {
476 filelock("$config{spool_dir}/lock/merge");
477 $data = lockreadbug(@_);
478 if (not defined $data) {
485 =head2 lock_read_all_merged_bugs
487 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
489 Performs a filelock, then reads the bug passed. If the bug is merged,
490 locks the merge lock, then reads and locks all of the other merged
491 bugs. Returns a list of the number of locks and the bug data for all
494 Will also return undef if any of the merged bugs failed to be read,
495 even if all of the others were read properly.
499 sub lock_read_all_merged_bugs {
500 my %param = validate_with(params => \@_,
501 spec => {bug => {type => SCALAR,
504 location => {type => SCALAR,
507 locks => {type => HASHREF,
513 my @data = read_bug(bug => $param{bug},
515 exists $param{location} ? (location => $param{location}):(),
516 exists $param{locks} ? (locks => $param{locks}):(),
518 if (not @data or not defined $data[0]) {
522 if (not length $data[0]->{mergedwith}) {
523 return ($locks,@data);
525 unfilelock(exists $param{locks}?$param{locks}:());
527 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
529 @data = read_bug(bug => $param{bug},
531 exists $param{location} ? (location => $param{location}):(),
532 exists $param{locks} ? (locks => $param{locks}):(),
534 if (not @data or not defined $data[0]) {
535 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
540 my @bugs = split / /, $data[0]->{mergedwith};
541 push @bugs, $param{bug};
542 for my $bug (@bugs) {
544 if ($bug != $param{bug}) {
546 read_bug(bug => $bug,
548 exists $param{location} ? (location => $param{location}):(),
549 exists $param{locks} ? (locks => $param{locks}):(),
551 if (not defined $newdata) {
553 unfilelock(exists $param{locks}?$param{locks}:());
556 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
561 # perform a sanity check to make sure that the merged bugs
562 # are all merged with eachother
563 # We do a cmp sort instead of an <=> sort here, because that's
566 join(' ',grep {$_ != $bug }
569 if ($newdata->{mergedwith} ne $expectmerge) {
571 unfilelock(exists $param{locks}?$param{locks}:());
573 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
577 return ($locks,@data);
582 my $new_bug_num = new_bug(copy => $data->{bug_num});
584 Creates a new bug and returns the new bug number upon success.
592 validate_with(params => \@_,
593 spec => {copy => {type => SCALAR,
599 filelock("nextnumber.lock");
600 my $nn_fh = IO::File->new("nextnumber",'r') or
601 die "Unable to open nextnuber for reading: $!";
604 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
606 overwritefile("nextnumber",
609 my $nn_hash = get_hashname($nn);
611 my $c_hash = get_hashname($param{copy});
612 for my $file (qw(log status summary report)) {
613 copy("db-h/$c_hash/$param{copy}.$file",
614 "db-h/$nn_hash/${nn}.$file")
618 for my $file (qw(log status summary report)) {
619 overwritefile("db-h/$nn_hash/${nn}.$file",
624 # this probably needs to be munged to do something more elegant
625 # &bughook('new', $clone, $data);
632 my @v1fieldorder = qw(originator date subject msgid package
633 keywords done forwarded mergedwith severity);
637 my $content = makestatus($status,$version)
638 my $content = makestatus($status);
640 Creates the content for a status file based on the $status hashref
643 Really only useful for writebug
645 Currently defaults to version 2 (non-encoded rfc1522 names) but will
646 eventually default to version 3. If you care, you should specify a
652 my ($data,$version) = @_;
653 $version = 3 unless defined $version;
657 my %newdata = %$data;
658 for my $field (qw(found fixed)) {
659 if (exists $newdata{$field}) {
660 $newdata{"${field}_date"} =
661 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
664 %newdata = %{join_status_fields(\%newdata)};
666 %newdata = encode_utf8_structure(%newdata);
669 for my $field (@rfc1522_fields) {
670 $newdata{$field} = encode_rfc1522($newdata{$field});
674 # this is a bit of a hack; we should never, ever have \r or \n in
675 # the fields of status. Kill them off here. [Eventually, this
676 # should be superfluous.]
677 for my $field (keys %newdata) {
678 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
682 for my $field (@v1fieldorder) {
683 if (exists $newdata{$field} and defined $newdata{$field}) {
684 $contents .= "$newdata{$field}\n";
689 } elsif ($version == 2 or $version == 3) {
690 # Version 2 or 3. Add a file format version number for the sake of
691 # further extensibility in the future.
692 $contents .= "Format-Version: $version\n";
693 for my $field (keys %fields) {
694 if (exists $newdata{$field} and defined $newdata{$field}
695 and $newdata{$field} ne '') {
696 # Output field names in proper case, e.g. 'Merged-With'.
697 my $properfield = $fields{$field};
698 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
699 my $data = $newdata{$field};
700 $contents .= "$properfield: $data\n";
709 writebug($bug_num,$status,$location,$minversion,$disablebughook)
711 Writes the bug status and summary files out.
713 Skips writing out a status file if minversion is 2
715 Does not call bughook if disablebughook is true.
720 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
723 my %outputs = (1 => 'status', 3 => 'summary');
724 for my $version (keys %outputs) {
725 next if defined $minversion and $version < $minversion;
726 my $status = getbugcomponent($ref, $outputs{$version}, $location);
727 die "can't find location for $ref" unless defined $status;
730 open $sfh,">","$status.new" or
731 die "opening $status.new: $!";
734 open $sfh,">","$status.new" or
735 die "opening $status.new: $!";
737 print {$sfh} makestatus($data, $version) or
738 die "writing $status.new: $!";
739 close($sfh) or die "closing $status.new: $!";
745 rename("$status.new",$status) || die "installing new $status: $!";
748 # $disablebughook is a bit of a hack to let format migration scripts use
749 # this function rather than having to duplicate it themselves.
750 &bughook($change,$ref,$data) unless $disablebughook;
753 =head2 unlockwritebug
755 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
757 Writes a bug, then calls unfilelock; see writebug for what these
769 The following functions are exported with the :versions tag
771 =head2 addfoundversions
773 addfoundversions($status,$package,$version,$isbinary);
775 All use of this should be phased out in favor of Debbugs::Control::fixed/found
780 sub addfoundversions {
784 my $isbinary = shift;
785 return unless defined $version;
786 undef $package if defined $package and $package =~ m[(?:\s|/)];
787 my $source = $package;
788 if (defined $package and $package =~ s/^src://) {
793 if (defined $package and $isbinary) {
794 my @srcinfo = binary_to_source(binary => $package,
795 version => $version);
797 # We know the source package(s). Use a fully-qualified version.
798 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
801 # Otherwise, an unqualified version will have to do.
805 # Strip off various kinds of brain-damage.
807 $version =~ s/ *\(.*\)//;
808 $version =~ s/ +[A-Za-z].*//;
810 foreach my $ver (split /[,\s]+/, $version) {
811 my $sver = defined($source) ? "$source/$ver" : '';
812 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
813 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
815 @{$data->{fixed_versions}} =
816 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
820 =head2 removefoundversions
822 removefoundversions($data,$package,$versiontoremove)
824 Removes found versions from $data
826 If a version is fully qualified (contains /) only versions matching
827 exactly are removed. Otherwise, all versions matching the version
830 Currently $package and $isbinary are entirely ignored, but accepted
831 for backwards compatibility.
835 sub removefoundversions {
839 my $isbinary = shift;
840 return unless defined $version;
842 foreach my $ver (split /[,\s]+/, $version) {
844 # fully qualified version
845 @{$data->{found_versions}} =
847 @{$data->{found_versions}};
850 # non qualified version; delete all matchers
851 @{$data->{found_versions}} =
852 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
853 @{$data->{found_versions}};
859 sub addfixedversions {
863 my $isbinary = shift;
864 return unless defined $version;
865 undef $package if defined $package and $package =~ m[(?:\s|/)];
866 my $source = $package;
868 if (defined $package and $isbinary) {
869 my @srcinfo = binary_to_source(binary => $package,
870 version => $version);
872 # We know the source package(s). Use a fully-qualified version.
873 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
876 # Otherwise, an unqualified version will have to do.
880 # Strip off various kinds of brain-damage.
882 $version =~ s/ *\(.*\)//;
883 $version =~ s/ +[A-Za-z].*//;
885 foreach my $ver (split /[,\s]+/, $version) {
886 my $sver = defined($source) ? "$source/$ver" : '';
887 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
888 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
890 @{$data->{found_versions}} =
891 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
895 sub removefixedversions {
899 my $isbinary = shift;
900 return unless defined $version;
902 foreach my $ver (split /[,\s]+/, $version) {
904 # fully qualified version
905 @{$data->{fixed_versions}} =
907 @{$data->{fixed_versions}};
910 # non qualified version; delete all matchers
911 @{$data->{fixed_versions}} =
912 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
913 @{$data->{fixed_versions}};
924 Split a package string from the status file into a list of package names.
930 return unless defined $pkgs;
931 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
935 =head2 bug_archiveable
937 bug_archiveable(bug => $bug_num);
943 =item bug -- bug number (required)
945 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
947 =item version -- Debbugs::Version information (optional)
949 =item days_until -- return days until the bug can be archived
953 Returns 1 if the bug can be archived
954 Returns 0 if the bug cannot be archived
956 If days_until is true, returns the number of days until the bug can be
957 archived, -1 if it cannot be archived. 0 means that the bug can be
958 archived the next time the archiver runs.
960 Returns undef on failure.
964 # This will eventually need to be fixed before we start using mod_perl
965 our $version_cache = {};
967 my %param = validate_with(params => \@_,
968 spec => {bug => {type => SCALAR,
971 status => {type => HASHREF,
974 days_until => {type => BOOLEAN,
977 ignore_time => {type => BOOLEAN,
982 # This is what we return if the bug cannot be archived.
983 my $cannot_archive = $param{days_until}?-1:0;
984 # read the status information
985 my $status = $param{status};
986 if (not exists $param{status} or not defined $status) {
987 $status = read_bug(bug=>$param{bug});
988 if (not defined $status) {
989 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
993 # Bugs can be archived if they are
995 if (not defined $status->{done} or not length $status->{done}) {
996 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
997 return $cannot_archive
999 # Check to make sure that the bug has none of the unremovable tags set
1000 if (@{$config{removal_unremovable_tags}}) {
1001 for my $tag (split ' ', ($status->{keywords}||'')) {
1002 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
1003 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
1004 return $cannot_archive;
1009 # If we just are checking if the bug can be archived, we'll not even bother
1010 # checking the versioning information if the bug has been -done for less than 28 days.
1011 my $log_file = getbugcomponent($param{bug},'log');
1012 if (not defined $log_file) {
1013 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
1014 return $cannot_archive;
1016 my $max_log_age = max(map {$config{remove_age} - -M $_}
1017 $log_file, map {my $log = getbugcomponent($_,'log');
1018 defined $log ? ($log) : ();
1020 split / /, $status->{mergedwith}
1022 if (not $param{days_until} and not $param{ignore_time}
1023 and $max_log_age > 0
1025 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
1026 return $cannot_archive;
1028 # At this point, we have to get the versioning information for this bug.
1029 # We examine the set of distribution tags. If a bug has no distribution
1030 # tags set, we assume a default set, otherwise we use the tags the bug
1033 # In cases where we are assuming a default set, if the severity
1034 # is strong, we use the strong severity default; otherwise, we
1035 # use the normal default.
1037 # There must be fixed_versions for us to look at the versioning
1039 my $min_fixed_time = time;
1040 my $min_archive_days = 0;
1041 if (@{$status->{fixed_versions}}) {
1043 @dist_tags{@{$config{removal_distribution_tags}}} =
1044 (1) x @{$config{removal_distribution_tags}};
1046 for my $tag (split ' ', ($status->{keywords}||'')) {
1047 next unless exists $config{distribution_aliases}{$tag};
1048 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1049 $dists{$config{distribution_aliases}{$tag}} = 1;
1051 if (not keys %dists) {
1052 if (isstrongseverity($status->{severity})) {
1053 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1054 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1057 @dists{@{$config{removal_default_distribution_tags}}} =
1058 (1) x @{$config{removal_default_distribution_tags}};
1061 my %source_versions;
1062 my @sourceversions = get_versions(package => $status->{package},
1063 dist => [keys %dists],
1066 @source_versions{@sourceversions} = (1) x @sourceversions;
1067 # If the bug has not been fixed in the versions actually
1068 # distributed, then it cannot be archived.
1069 if ('found' eq max_buggy(bug => $param{bug},
1070 sourceversions => [keys %source_versions],
1071 found => $status->{found_versions},
1072 fixed => $status->{fixed_versions},
1073 version_cache => $version_cache,
1074 package => $status->{package},
1076 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1077 return $cannot_archive;
1079 # Since the bug has at least been fixed in the architectures
1080 # that matters, we check to see how long it has been fixed.
1082 # If $param{ignore_time}, then we should ignore time.
1083 if ($param{ignore_time}) {
1084 return $param{days_until}?0:1;
1087 # To do this, we order the times from most recent to oldest;
1088 # when we come to the first found version, we stop.
1089 # If we run out of versions, we only report the time of the
1091 my %time_versions = get_versions(package => $status->{package},
1092 dist => [keys %dists],
1096 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1097 my $buggy = buggy(bug => $param{bug},
1098 version => $version,
1099 found => $status->{found_versions},
1100 fixed => $status->{fixed_versions},
1101 version_cache => $version_cache,
1102 package => $status->{package},
1104 last if $buggy eq 'found';
1105 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1107 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1108 # if there are no versions in the archive at all, then
1109 # we can archive if enough days have passed
1112 # If $param{ignore_time}, then we should ignore time.
1113 if ($param{ignore_time}) {
1114 return $param{days_until}?0:1;
1116 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1117 my $age = ceil($max_log_age);
1118 if ($age > 0 or $min_archive_days > 0) {
1119 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1120 return $param{days_until}?max($age,$min_archive_days):0;
1123 return $param{days_until}?0:1;
1128 =head2 get_bug_status
1130 my $status = get_bug_status(bug => $nnn);
1132 my $status = get_bug_status($bug_num)
1138 =item bug -- scalar bug number
1140 =item status -- optional hashref of bug status as returned by readbug
1141 (can be passed to avoid rereading the bug information)
1143 =item bug_index -- optional tied index of bug status infomration;
1144 currently not correctly implemented.
1146 =item version -- optional version(s) to check package status at
1148 =item dist -- optional distribution(s) to check package status at
1150 =item arch -- optional architecture(s) to check package status at
1152 =item bugusertags -- optional hashref of bugusertags
1154 =item sourceversion -- optional arrayref of source/version; overrides
1155 dist, arch, and version. [The entries in this array must be in the
1156 "source/version" format.] Eventually this can be used to for caching.
1158 =item indicatesource -- if true, indicate which source packages this
1159 bug could belong to (or does belong to in the case of bugs assigned to
1160 a source package). Defaults to true.
1164 Note: Currently the version information is cached; this needs to be
1165 changed before using this function in long lived programs.
1169 Currently returns a hashref of status with the following keys.
1173 =item id -- bug number
1175 =item bug_num -- duplicate of id
1177 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1179 =item tags -- duplicate of keywords
1181 =item package -- name of package that the bug is assigned to
1183 =item severity -- severity of the bug
1185 =item pending -- pending state of the bug; one of following possible
1186 values; values listed later have precedence if multiple conditions are
1191 =item pending -- default state
1193 =item forwarded -- bug has been forwarded
1195 =item pending-fixed -- bug is tagged pending
1197 =item fixed -- bug is tagged fixed
1199 =item absent -- bug does not apply to this distribution/architecture
1201 =item done -- bug is resolved in this distribution/architecture
1205 =item location -- db-h or archive; the location in the filesystem
1207 =item subject -- title of the bug
1209 =item last_modified -- epoch that the bug was last modified
1211 =item date -- epoch that the bug was filed
1213 =item originator -- bug reporter
1215 =item log_modified -- epoch that the log file was last modified
1217 =item msgid -- Message id of the original bug report
1222 Other key/value pairs are returned but are not currently documented here.
1226 sub get_bug_status {
1231 {bug => {type => SCALAR,
1234 status => {type => HASHREF,
1237 bug_index => {type => OBJECT,
1240 version => {type => SCALAR|ARRAYREF,
1243 dist => {type => SCALAR|ARRAYREF,
1246 arch => {type => SCALAR|ARRAYREF,
1249 bugusertags => {type => HASHREF,
1252 sourceversions => {type => ARRAYREF,
1255 indicatesource => {type => BOOLEAN,
1258 binary_to_source_cache => {type => HASHREF,
1261 schema => {type => OBJECT,
1265 my %param = validate_with(params => \@_,
1270 if (defined $param{bug_index} and
1271 exists $param{bug_index}{$param{bug}}) {
1272 %status = %{ $param{bug_index}{$param{bug}} };
1273 $status{pending} = $status{ status };
1274 $status{id} = $param{bug};
1277 if (defined $param{status}) {
1278 %status = %{$param{status}};
1280 elsif (defined $param{schema}) {
1281 my $b = $param{schema}->resultset('Bug')->
1282 search_rs({'me.id' => $param{bug}},
1283 {prefetch => [{'bug_tags'=>'tag'},
1285 {'bug_binpackages'=> 'bin_pkg'},
1286 {'bug_srcpackages'=> 'src_pkg'},
1287 {'bug_user_tags'=>{'user_tag'=>'correspondent'}},
1288 {owner => 'correspondent_full_names'},
1289 {submitter => 'correspondent_full_names'},
1291 'bug_mergeds_merged',
1292 'bug_blocks_blocks',
1294 {'bug_vers' => ['src_pkg','src_ver']},
1296 '+columns' => [qw(subject log_modified creation last_modified)],
1298 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
1301 join(' ',map {$_->{tag}{tag}} @{$b->{bug_tags}});
1302 $status{tags} = $status{keywords};
1303 $status{subject} = $b->{subject};
1304 $status{bug_num} = $b->{id};
1305 $status{severity} = $b->{severity}{severity};
1308 (map {$_->{bin_pkg}{pkg}} @{$b->{bug_binpackages}//[]}),
1309 (map {$_->{src_pkg}{pkg}} @{$b->{bug_srcpackages}//[]}));
1310 $status{originator} = $b->{submitter_full};
1311 $status{log_modified} =
1312 DateTime::Format::Pg->parse_datetime($b->{log_modified})->epoch;
1314 DateTime::Format::Pg->parse_datetime($b->{creation})->epoch;
1315 $status{last_modified} =
1316 DateTime::Format::Pg->parse_datetime($b->{last_modified})->epoch;
1319 uniq(sort(map {$_->{block}}
1320 @{$b->{bug_blocks_block}},
1322 $status{blockedby} =
1324 uniq(sort(map {$_->{bug}}
1325 @{$b->{bug_blocks_bug}},
1327 $status{mergedwith} =
1328 join(' ',uniq(sort(map {$_->{bug},$_->{merged}}
1329 @{$b->{bug_merged_bugs}},
1330 @{$b->{bug_mergeds_merged}},
1332 $status{fixed_versions} =
1333 [map {$_->{found}?():$_->{ver_string}} @{$b->{bug_vers}}];
1334 $status{found_versions} =
1335 [map {$_->{found}?$_->{ver_string}:()} @{$b->{bug_vers}}];
1338 my $location = getbuglocation($param{bug}, 'summary');
1339 return {} if not defined $location or not length $location;
1340 %status = %{ readbug( $param{bug}, $location ) };
1342 $status{id} = $param{bug};
1344 if (defined $param{bugusertags}{$param{bug}}) {
1345 $status{keywords} = "" unless defined $status{keywords};
1346 $status{keywords} .= " " unless $status{keywords} eq "";
1347 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1349 $status{tags} = $status{keywords};
1350 my %tags = map { $_ => 1 } split ' ', $status{tags};
1352 $status{package} = '' if not defined $status{package};
1353 $status{"package"} =~ s/\s*$//;
1355 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1357 exists $param{binary_to_source_cache}?
1358 (cache =>$param{binary_to_source_cache}):(),
1361 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1362 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1364 $status{"pending"} = 'pending';
1365 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1366 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1367 $status{"pending"} = 'fixed' if ($tags{fixed});
1370 my $presence = bug_presence(status => \%status,
1371 map{(exists $param{$_})?($_,$param{$_}):()}
1372 qw(bug sourceversions arch dist version found fixed package)
1374 if (defined $presence) {
1375 if ($presence eq 'fixed') {
1376 $status{pending} = 'done';
1378 elsif ($presence eq 'absent') {
1379 $status{pending} = 'absent';
1387 my $precence = bug_presence(bug => nnn,
1391 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1392 is found, absent, fixed, or no information is available in the
1393 distribution (dist) and/or architecture (arch) specified.
1400 =item bug -- scalar bug number
1402 =item status -- optional hashref of bug status as returned by readbug
1403 (can be passed to avoid rereading the bug information)
1405 =item bug_index -- optional tied index of bug status infomration;
1406 currently not correctly implemented.
1408 =item version -- optional version to check package status at
1410 =item dist -- optional distribution to check package status at
1412 =item arch -- optional architecture to check package status at
1414 =item sourceversion -- optional arrayref of source/version; overrides
1415 dist, arch, and version. [The entries in this array must be in the
1416 "source/version" format.] Eventually this can be used to for caching.
1423 my %param = validate_with(params => \@_,
1424 spec => {bug => {type => SCALAR,
1427 status => {type => HASHREF,
1430 version => {type => SCALAR|ARRAYREF,
1433 dist => {type => SCALAR|ARRAYREF,
1436 arch => {type => SCALAR|ARRAYREF,
1439 sourceversions => {type => ARRAYREF,
1445 if (defined $param{status}) {
1446 %status = %{$param{status}};
1449 my $location = getbuglocation($param{bug}, 'summary');
1450 return {} if not length $location;
1451 %status = %{ readbug( $param{bug}, $location ) };
1455 my $pseudo_desc = getpseudodesc();
1456 if (not exists $param{sourceversions}) {
1458 # pseudopackages do not have source versions by definition.
1459 if (exists $pseudo_desc->{$status{package}}) {
1462 elsif (defined $param{version}) {
1463 foreach my $arch (make_list($param{arch})) {
1464 for my $package (split /\s*,\s*/, $status{package}) {
1465 my @temp = makesourceversions($package,
1467 make_list($param{version})
1469 @sourceversions{@temp} = (1) x @temp;
1472 } elsif (defined $param{dist}) {
1473 my %affects_distribution_tags;
1474 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1475 (1) x @{$config{affects_distribution_tags}};
1476 my $some_distributions_disallowed = 0;
1477 my %allowed_distributions;
1478 for my $tag (split ' ', ($status{keywords}||'')) {
1479 if (exists $config{distribution_aliases}{$tag} and
1480 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1481 $some_distributions_disallowed = 1;
1482 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1484 elsif (exists $affects_distribution_tags{$tag}) {
1485 $some_distributions_disallowed = 1;
1486 $allowed_distributions{$tag} = 1;
1489 my @archs = make_list(exists $param{arch}?$param{arch}:());
1490 GET_SOURCE_VERSIONS:
1491 foreach my $arch (@archs) {
1492 for my $package (split /\s*,\s*/, $status{package}) {
1495 if ($package =~ /^src:(.+)$/) {
1499 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1500 # if some distributions are disallowed,
1501 # and this isn't an allowed
1502 # distribution, then we ignore this
1503 # distribution for the purposees of
1505 if ($some_distributions_disallowed and
1506 not exists $allowed_distributions{$dist}) {
1509 push @versions, get_versions(package => $package,
1511 ($source?(arch => 'source'):
1512 (defined $arch?(arch => $arch):())),
1515 next unless @versions;
1516 my @temp = make_source_versions(package => $package,
1518 versions => \@versions,
1520 @sourceversions{@temp} = (1) x @temp;
1523 # this should really be split out into a subroutine,
1524 # but it'd touch so many things currently, that we fake
1525 # it; it's needed to properly handle bugs which are
1526 # erroneously assigned to the binary package, and we'll
1527 # probably have it go away eventually.
1528 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1530 goto GET_SOURCE_VERSIONS;
1534 # TODO: This should probably be handled further out for efficiency and
1535 # for more ease of distinguishing between pkg= and src= queries.
1536 # DLA: src= queries should just pass arch=source, and they'll be happy.
1537 @sourceversions = keys %sourceversions;
1540 @sourceversions = @{$param{sourceversions}};
1542 my $maxbuggy = 'undef';
1543 if (@sourceversions) {
1544 $maxbuggy = max_buggy(bug => $param{bug},
1545 sourceversions => \@sourceversions,
1546 found => $status{found_versions},
1547 fixed => $status{fixed_versions},
1548 package => $status{package},
1549 version_cache => $version_cache,
1552 elsif (defined $param{dist} and
1553 not exists $pseudo_desc->{$status{package}}) {
1556 if (length($status{done}) and
1557 (not @sourceversions or not @{$status{fixed_versions}})) {
1572 =item bug -- scalar bug number
1574 =item sourceversion -- optional arrayref of source/version; overrides
1575 dist, arch, and version. [The entries in this array must be in the
1576 "source/version" format.] Eventually this can be used to for caching.
1580 Note: Currently the version information is cached; this needs to be
1581 changed before using this function in long lived programs.
1586 my %param = validate_with(params => \@_,
1587 spec => {bug => {type => SCALAR,
1590 sourceversions => {type => ARRAYREF,
1593 found => {type => ARRAYREF,
1596 fixed => {type => ARRAYREF,
1599 package => {type => SCALAR,
1601 version_cache => {type => HASHREF,
1606 # Resolve bugginess states (we might be looking at multiple
1607 # architectures, say). Found wins, then fixed, then absent.
1608 my $maxbuggy = 'absent';
1609 for my $package (split /\s*,\s*/, $param{package}) {
1610 for my $version (@{$param{sourceversions}}) {
1611 my $buggy = buggy(bug => $param{bug},
1612 version => $version,
1613 found => $param{found},
1614 fixed => $param{fixed},
1615 version_cache => $param{version_cache},
1616 package => $package,
1618 if ($buggy eq 'found') {
1620 } elsif ($buggy eq 'fixed') {
1621 $maxbuggy = 'fixed';
1638 Returns the output of Debbugs::Versions::buggy for a particular
1639 package, version and found/fixed set. Automatically turns found, fixed
1640 and version into source/version strings.
1642 Caching can be had by using the version_cache, but no attempt to check
1643 to see if the on disk information is more recent than the cache is
1644 made. [This will need to be fixed for long-lived processes.]
1649 my %param = validate_with(params => \@_,
1650 spec => {bug => {type => SCALAR,
1653 found => {type => ARRAYREF,
1656 fixed => {type => ARRAYREF,
1659 version_cache => {type => HASHREF,
1662 package => {type => SCALAR,
1664 version => {type => SCALAR,
1668 my @found = @{$param{found}};
1669 my @fixed = @{$param{fixed}};
1670 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1671 # We have non-source version versions
1672 @found = makesourceversions($param{package},undef,
1675 @fixed = makesourceversions($param{package},undef,
1679 if ($param{version} !~ m{/}) {
1680 my ($version) = makesourceversions($param{package},undef,
1683 $param{version} = $version if defined $version;
1685 # Figure out which source packages we need
1687 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1688 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1689 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1690 $param{version} =~ m{/};
1692 if (not defined $param{version_cache} or
1693 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1694 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1695 foreach my $source (keys %sources) {
1696 my $srchash = substr $source, 0, 1;
1697 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1698 if (not defined $version_fh) {
1699 # We only want to warn if it's a package which actually has a maintainer
1700 my $maints = getmaintainers();
1701 next if not exists $maints->{$source};
1702 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1705 $version->load($version_fh);
1707 if (defined $param{version_cache}) {
1708 $param{version_cache}{join(',',sort keys %sources)} = $version;
1712 $version = $param{version_cache}{join(',',sort keys %sources)};
1714 return $version->buggy($param{version},\@found,\@fixed);
1717 sub isstrongseverity {
1718 my $severity = shift;
1719 $severity = $config{default_severity} if
1720 not defined $severity or $severity eq '';
1721 return grep { $_ eq $severity } @{$config{strong_severities}};
1726 =head2 generate_index_db_line
1728 my $data = read_bug(bug => $bug,
1729 location => $initialdir);
1730 # generate_index_db_line hasn't been written yet at all.
1731 my $line = generate_index_db_line($data);
1733 Returns a line for a bug suitable to be written out to index.db.
1737 sub generate_index_db_line {
1738 my ($data,$bug) = @_;
1740 # just in case someone has given us a split out data
1741 $data = join_status_fields($data);
1743 my $whendone = "open";
1744 my $severity = $config{default_severity};
1745 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1746 $pkglist =~ s/^,+//;
1747 $pkglist =~ s/,+$//;
1748 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1749 $whendone = "done" if defined $data->{done} and length $data->{done};
1750 $severity = $data->{severity} if length $data->{severity};
1751 return sprintf "%s %d %d %s [%s] %s %s\n",
1752 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1753 $data->{originator}, $severity, $data->{keywords};
1758 =head1 PRIVATE FUNCTIONS
1762 sub update_realtime {
1763 my ($file, %bugs) = @_;
1765 # update realtime index.db
1767 return () unless keys %bugs;
1768 my $idx_old = IO::File->new($file,'r')
1769 or die "Couldn't open ${file}: $!";
1770 my $idx_new = IO::File->new($file.'.new','w')
1771 or die "Couldn't open ${file}.new: $!";
1773 binmode($idx_old,':raw:utf8');
1774 binmode($idx_new,':raw:encoding(UTF-8)');
1775 my $min_bug = min(keys %bugs);
1779 while($line = <$idx_old>) {
1780 @line = split /\s/, $line;
1781 # Two cases; replacing existing line or adding new line
1782 if (exists $bugs{$line[1]}) {
1783 my $new = $bugs{$line[1]};
1784 delete $bugs{$line[1]};
1785 $min_bug = min(keys %bugs);
1786 if ($new eq "NOCHANGE") {
1787 print {$idx_new} $line;
1788 $changed_bugs{$line[1]} = $line;
1789 } elsif ($new eq "REMOVE") {
1790 $changed_bugs{$line[1]} = $line;
1792 print {$idx_new} $new;
1793 $changed_bugs{$line[1]} = $line;
1797 while ($line[1] > $min_bug) {
1798 print {$idx_new} $bugs{$min_bug};
1799 delete $bugs{$min_bug};
1800 last unless keys %bugs;
1801 $min_bug = min(keys %bugs);
1803 print {$idx_new} $line;
1805 last unless keys %bugs;
1807 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1809 print {$idx_new} <$idx_old>;
1814 rename("$file.new", $file);
1816 return %changed_bugs;
1819 sub bughook_archive {
1821 filelock("$config{spool_dir}/debbugs.trace.lock");
1822 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1823 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1824 map{($_,'REMOVE')} @refs);
1825 update_realtime("$config{spool_dir}/index.archive.realtime",
1831 my ( $type, %bugs_temp ) = @_;
1832 filelock("$config{spool_dir}/debbugs.trace.lock");
1835 for my $bug (keys %bugs_temp) {
1836 my $data = $bugs_temp{$bug};
1837 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1839 $bugs{$bug} = generate_index_db_line($data,$bug);
1841 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);