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 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
317 (package => \&splitpackages,
318 affects => \&splitpackages,
319 blocks => $ditch_empty_space,
320 blockedby => $ditch_empty_space,
321 # this isn't strictly correct, but we'll split both of them for
322 # the time being until we ditch all use of keywords everywhere
324 keywords => $ditch_empty_space,
325 tags => $ditch_empty_space,
326 found_versions => $ditch_empty_space,
327 fixed_versions => $ditch_empty_space,
328 mergedwith => $ditch_empty_space,
331 sub split_status_fields {
332 my @data = @{dclone(\@_)};
333 for my $data (@data) {
334 next if not defined $data;
335 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
336 not (ref($data) and ref($data) eq 'HASH');
337 for my $field (keys %{$data}) {
338 next unless defined $data->{$field};
339 if (exists $split_fields{$field}) {
340 next if ref($data->{$field});
342 if (ref($split_fields{$field}) eq 'CODE') {
343 @elements = &{$split_fields{$field}}($data->{$field});
345 elsif (not ref($split_fields{$field}) or
346 UNIVERSAL::isa($split_fields{$field},'Regex')
348 @elements = split $split_fields{$field}, $data->{$field};
350 $data->{$field} = \@elements;
354 return wantarray?@data:$data[0];
357 =head2 join_status_fields
359 my @data = join_status_fields(@data);
361 Handles joining the splitable status fields. (Basically, the inverse
362 of split_status_fields.
364 Primarily called from makestatus, but may be useful for other
365 functions after calling split_status_fields (or for legacy functions
366 if we transition to split fields by default).
370 sub join_status_fields {
377 found_versions => ' ',
378 fixed_versions => ' ',
383 my @data = @{dclone(\@_)};
384 for my $data (@data) {
385 next if not defined $data;
386 croak "Passed an element which is not a hashref to split_status_field: ".
388 if ref($data) ne 'HASH';
389 for my $field (keys %{$data}) {
390 next unless defined $data->{$field};
391 next unless ref($data->{$field}) eq 'ARRAY';
392 next unless exists $join_fields{$field};
393 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
396 return wantarray?@data:$data[0];
402 lockreadbug($bug_num,$location)
404 Performs a filelock, then reads the bug; the bug is unlocked if the
405 return is undefined, otherwise, you need to call unfilelock or
408 See readbug above for information on what this returns
413 my ($lref, $location) = @_;
414 return read_bug(bug => $lref, location => $location, lock => 1);
417 =head2 lockreadbugmerge
419 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
421 Performs a filelock, then reads the bug. If the bug is merged, locks
422 the merge lock. Returns a list of the number of locks and the bug
427 sub lockreadbugmerge {
428 my ($bug_num,$location) = @_;
429 my $data = lockreadbug(@_);
430 if (not defined $data) {
433 if (not length $data->{mergedwith}) {
437 filelock("$config{spool_dir}/lock/merge");
438 $data = lockreadbug(@_);
439 if (not defined $data) {
446 =head2 lock_read_all_merged_bugs
448 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
450 Performs a filelock, then reads the bug passed. If the bug is merged,
451 locks the merge lock, then reads and locks all of the other merged
452 bugs. Returns a list of the number of locks and the bug data for all
455 Will also return undef if any of the merged bugs failed to be read,
456 even if all of the others were read properly.
460 sub lock_read_all_merged_bugs {
461 my %param = validate_with(params => \@_,
462 spec => {bug => {type => SCALAR,
465 location => {type => SCALAR,
468 locks => {type => HASHREF,
474 my @data = read_bug(bug => $param{bug},
476 exists $param{location} ? (location => $param{location}):(),
477 exists $param{locks} ? (locks => $param{locks}):(),
479 if (not @data or not defined $data[0]) {
483 if (not length $data[0]->{mergedwith}) {
484 return ($locks,@data);
486 unfilelock(exists $param{locks}?$param{locks}:());
488 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
490 @data = read_bug(bug => $param{bug},
492 exists $param{location} ? (location => $param{location}):(),
493 exists $param{locks} ? (locks => $param{locks}):(),
495 if (not @data or not defined $data[0]) {
496 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
501 my @bugs = split / /, $data[0]->{mergedwith};
502 push @bugs, $param{bug};
503 for my $bug (@bugs) {
505 if ($bug != $param{bug}) {
507 read_bug(bug => $bug,
509 exists $param{location} ? (location => $param{location}):(),
510 exists $param{locks} ? (locks => $param{locks}):(),
512 if (not defined $newdata) {
514 unfilelock(exists $param{locks}?$param{locks}:());
517 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
522 # perform a sanity check to make sure that the merged bugs
523 # are all merged with eachother
524 # We do a cmp sort instead of an <=> sort here, because that's
526 my $expectmerge= join(' ',grep {$_ != $bug } sort @bugs);
527 if ($newdata->{mergedwith} ne $expectmerge) {
529 unfilelock(exists $param{locks}?$param{locks}:());
531 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
535 return ($locks,@data);
540 my $new_bug_num = new_bug(copy => $data->{bug_num});
542 Creates a new bug and returns the new bug number upon success.
550 validate_with(params => \@_,
551 spec => {copy => {type => SCALAR,
557 filelock("nextnumber.lock");
558 my $nn_fh = IO::File->new("nextnumber",'r') or
559 die "Unable to open nextnuber for reading: $!";
562 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
564 overwritefile("nextnumber",
567 my $nn_hash = get_hashname($nn);
569 my $c_hash = get_hashname($param{copy});
570 for my $file (qw(log status summary report)) {
571 copy("db-h/$c_hash/$param{copy}.$file",
572 "db-h/$nn_hash/${nn}.$file")
576 for my $file (qw(log status summary report)) {
577 overwritefile("db-h/$nn_hash/${nn}.$file",
582 # this probably needs to be munged to do something more elegant
583 # &bughook('new', $clone, $data);
590 my @v1fieldorder = qw(originator date subject msgid package
591 keywords done forwarded mergedwith severity);
595 my $content = makestatus($status,$version)
596 my $content = makestatus($status);
598 Creates the content for a status file based on the $status hashref
601 Really only useful for writebug
603 Currently defaults to version 2 (non-encoded rfc1522 names) but will
604 eventually default to version 3. If you care, you should specify a
610 my ($data,$version) = @_;
611 $version = 3 unless defined $version;
615 my %newdata = %$data;
616 for my $field (qw(found fixed)) {
617 if (exists $newdata{$field}) {
618 $newdata{"${field}_date"} =
619 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
622 %newdata = %{join_status_fields(\%newdata)};
624 %newdata = encode_utf8_structure(%newdata);
627 for my $field (@rfc1522_fields) {
628 $newdata{$field} = encode_rfc1522($newdata{$field});
632 # this is a bit of a hack; we should never, ever have \r or \n in
633 # the fields of status. Kill them off here. [Eventually, this
634 # should be superfluous.]
635 for my $field (keys %newdata) {
636 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
640 for my $field (@v1fieldorder) {
641 if (exists $newdata{$field} and defined $newdata{$field}) {
642 $contents .= "$newdata{$field}\n";
647 } elsif ($version == 2 or $version == 3) {
648 # Version 2 or 3. Add a file format version number for the sake of
649 # further extensibility in the future.
650 $contents .= "Format-Version: $version\n";
651 for my $field (keys %fields) {
652 if (exists $newdata{$field} and defined $newdata{$field}
653 and $newdata{$field} ne '') {
654 # Output field names in proper case, e.g. 'Merged-With'.
655 my $properfield = $fields{$field};
656 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
657 my $data = $newdata{$field};
658 $contents .= "$properfield: $data\n";
667 writebug($bug_num,$status,$location,$minversion,$disablebughook)
669 Writes the bug status and summary files out.
671 Skips writing out a status file if minversion is 2
673 Does not call bughook if disablebughook is true.
678 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
681 my %outputs = (1 => 'status', 3 => 'summary');
682 for my $version (keys %outputs) {
683 next if defined $minversion and $version < $minversion;
684 my $status = getbugcomponent($ref, $outputs{$version}, $location);
685 die "can't find location for $ref" unless defined $status;
688 open $sfh,">","$status.new" or
689 die "opening $status.new: $!";
692 open $sfh,">","$status.new" or
693 die "opening $status.new: $!";
695 print {$sfh} makestatus($data, $version) or
696 die "writing $status.new: $!";
697 close($sfh) or die "closing $status.new: $!";
703 rename("$status.new",$status) || die "installing new $status: $!";
706 # $disablebughook is a bit of a hack to let format migration scripts use
707 # this function rather than having to duplicate it themselves.
708 &bughook($change,$ref,$data) unless $disablebughook;
711 =head2 unlockwritebug
713 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
715 Writes a bug, then calls unfilelock; see writebug for what these
727 The following functions are exported with the :versions tag
729 =head2 addfoundversions
731 addfoundversions($status,$package,$version,$isbinary);
733 All use of this should be phased out in favor of Debbugs::Control::fixed/found
738 sub addfoundversions {
742 my $isbinary = shift;
743 return unless defined $version;
744 undef $package if defined $package and $package =~ m[(?:\s|/)];
745 my $source = $package;
746 if (defined $package and $package =~ s/^src://) {
751 if (defined $package and $isbinary) {
752 my @srcinfo = binary_to_source(binary => $package,
753 version => $version);
755 # We know the source package(s). Use a fully-qualified version.
756 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
759 # Otherwise, an unqualified version will have to do.
763 # Strip off various kinds of brain-damage.
765 $version =~ s/ *\(.*\)//;
766 $version =~ s/ +[A-Za-z].*//;
768 foreach my $ver (split /[,\s]+/, $version) {
769 my $sver = defined($source) ? "$source/$ver" : '';
770 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
771 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
773 @{$data->{fixed_versions}} =
774 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
778 =head2 removefoundversions
780 removefoundversions($data,$package,$versiontoremove)
782 Removes found versions from $data
784 If a version is fully qualified (contains /) only versions matching
785 exactly are removed. Otherwise, all versions matching the version
788 Currently $package and $isbinary are entirely ignored, but accepted
789 for backwards compatibility.
793 sub removefoundversions {
797 my $isbinary = shift;
798 return unless defined $version;
800 foreach my $ver (split /[,\s]+/, $version) {
802 # fully qualified version
803 @{$data->{found_versions}} =
805 @{$data->{found_versions}};
808 # non qualified version; delete all matchers
809 @{$data->{found_versions}} =
810 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
811 @{$data->{found_versions}};
817 sub addfixedversions {
821 my $isbinary = shift;
822 return unless defined $version;
823 undef $package if defined $package and $package =~ m[(?:\s|/)];
824 my $source = $package;
826 if (defined $package and $isbinary) {
827 my @srcinfo = binary_to_source(binary => $package,
828 version => $version);
830 # We know the source package(s). Use a fully-qualified version.
831 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
834 # Otherwise, an unqualified version will have to do.
838 # Strip off various kinds of brain-damage.
840 $version =~ s/ *\(.*\)//;
841 $version =~ s/ +[A-Za-z].*//;
843 foreach my $ver (split /[,\s]+/, $version) {
844 my $sver = defined($source) ? "$source/$ver" : '';
845 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
846 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
848 @{$data->{found_versions}} =
849 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
853 sub removefixedversions {
857 my $isbinary = shift;
858 return unless defined $version;
860 foreach my $ver (split /[,\s]+/, $version) {
862 # fully qualified version
863 @{$data->{fixed_versions}} =
865 @{$data->{fixed_versions}};
868 # non qualified version; delete all matchers
869 @{$data->{fixed_versions}} =
870 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
871 @{$data->{fixed_versions}};
882 Split a package string from the status file into a list of package names.
888 return unless defined $pkgs;
889 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
893 =head2 bug_archiveable
895 bug_archiveable(bug => $bug_num);
901 =item bug -- bug number (required)
903 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
905 =item version -- Debbugs::Version information (optional)
907 =item days_until -- return days until the bug can be archived
911 Returns 1 if the bug can be archived
912 Returns 0 if the bug cannot be archived
914 If days_until is true, returns the number of days until the bug can be
915 archived, -1 if it cannot be archived. 0 means that the bug can be
916 archived the next time the archiver runs.
918 Returns undef on failure.
922 # This will eventually need to be fixed before we start using mod_perl
923 our $version_cache = {};
925 my %param = validate_with(params => \@_,
926 spec => {bug => {type => SCALAR,
929 status => {type => HASHREF,
932 days_until => {type => BOOLEAN,
935 ignore_time => {type => BOOLEAN,
940 # This is what we return if the bug cannot be archived.
941 my $cannot_archive = $param{days_until}?-1:0;
942 # read the status information
943 my $status = $param{status};
944 if (not exists $param{status} or not defined $status) {
945 $status = read_bug(bug=>$param{bug});
946 if (not defined $status) {
947 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
951 # Bugs can be archived if they are
953 if (not defined $status->{done} or not length $status->{done}) {
954 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
955 return $cannot_archive
957 # Check to make sure that the bug has none of the unremovable tags set
958 if (@{$config{removal_unremovable_tags}}) {
959 for my $tag (split ' ', ($status->{keywords}||'')) {
960 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
961 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
962 return $cannot_archive;
967 # If we just are checking if the bug can be archived, we'll not even bother
968 # checking the versioning information if the bug has been -done for less than 28 days.
969 my $log_file = getbugcomponent($param{bug},'log');
970 if (not defined $log_file) {
971 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
972 return $cannot_archive;
974 my $max_log_age = max(map {$config{remove_age} - -M $_}
975 $log_file, map {my $log = getbugcomponent($_,'log');
976 defined $log ? ($log) : ();
978 split / /, $status->{mergedwith}
980 if (not $param{days_until} and not $param{ignore_time}
983 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
984 return $cannot_archive;
986 # At this point, we have to get the versioning information for this bug.
987 # We examine the set of distribution tags. If a bug has no distribution
988 # tags set, we assume a default set, otherwise we use the tags the bug
991 # In cases where we are assuming a default set, if the severity
992 # is strong, we use the strong severity default; otherwise, we
993 # use the normal default.
995 # There must be fixed_versions for us to look at the versioning
997 my $min_fixed_time = time;
998 my $min_archive_days = 0;
999 if (@{$status->{fixed_versions}}) {
1001 @dist_tags{@{$config{removal_distribution_tags}}} =
1002 (1) x @{$config{removal_distribution_tags}};
1004 for my $tag (split ' ', ($status->{keywords}||'')) {
1005 next unless exists $config{distribution_aliases}{$tag};
1006 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1007 $dists{$config{distribution_aliases}{$tag}} = 1;
1009 if (not keys %dists) {
1010 if (isstrongseverity($status->{severity})) {
1011 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1012 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1015 @dists{@{$config{removal_default_distribution_tags}}} =
1016 (1) x @{$config{removal_default_distribution_tags}};
1019 my %source_versions;
1020 my @sourceversions = get_versions(package => $status->{package},
1021 dist => [keys %dists],
1024 @source_versions{@sourceversions} = (1) x @sourceversions;
1025 # If the bug has not been fixed in the versions actually
1026 # distributed, then it cannot be archived.
1027 if ('found' eq max_buggy(bug => $param{bug},
1028 sourceversions => [keys %source_versions],
1029 found => $status->{found_versions},
1030 fixed => $status->{fixed_versions},
1031 version_cache => $version_cache,
1032 package => $status->{package},
1034 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1035 return $cannot_archive;
1037 # Since the bug has at least been fixed in the architectures
1038 # that matters, we check to see how long it has been fixed.
1040 # If $param{ignore_time}, then we should ignore time.
1041 if ($param{ignore_time}) {
1042 return $param{days_until}?0:1;
1045 # To do this, we order the times from most recent to oldest;
1046 # when we come to the first found version, we stop.
1047 # If we run out of versions, we only report the time of the
1049 my %time_versions = get_versions(package => $status->{package},
1050 dist => [keys %dists],
1054 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1055 my $buggy = buggy(bug => $param{bug},
1056 version => $version,
1057 found => $status->{found_versions},
1058 fixed => $status->{fixed_versions},
1059 version_cache => $version_cache,
1060 package => $status->{package},
1062 last if $buggy eq 'found';
1063 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1065 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1066 # if there are no versions in the archive at all, then
1067 # we can archive if enough days have passed
1070 # If $param{ignore_time}, then we should ignore time.
1071 if ($param{ignore_time}) {
1072 return $param{days_until}?0:1;
1074 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1075 my $age = ceil($max_log_age);
1076 if ($age > 0 or $min_archive_days > 0) {
1077 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1078 return $param{days_until}?max($age,$min_archive_days):0;
1081 return $param{days_until}?0:1;
1086 =head2 get_bug_status
1088 my $status = get_bug_status(bug => $nnn);
1090 my $status = get_bug_status($bug_num)
1096 =item bug -- scalar bug number
1098 =item status -- optional hashref of bug status as returned by readbug
1099 (can be passed to avoid rereading the bug information)
1101 =item bug_index -- optional tied index of bug status infomration;
1102 currently not correctly implemented.
1104 =item version -- optional version(s) to check package status at
1106 =item dist -- optional distribution(s) to check package status at
1108 =item arch -- optional architecture(s) to check package status at
1110 =item bugusertags -- optional hashref of bugusertags
1112 =item sourceversion -- optional arrayref of source/version; overrides
1113 dist, arch, and version. [The entries in this array must be in the
1114 "source/version" format.] Eventually this can be used to for caching.
1116 =item indicatesource -- if true, indicate which source packages this
1117 bug could belong to (or does belong to in the case of bugs assigned to
1118 a source package). Defaults to true.
1122 Note: Currently the version information is cached; this needs to be
1123 changed before using this function in long lived programs.
1127 Currently returns a hashref of status with the following keys.
1131 =item id -- bug number
1133 =item bug_num -- duplicate of id
1135 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1137 =item tags -- duplicate of keywords
1139 =item package -- name of package that the bug is assigned to
1141 =item severity -- severity of the bug
1143 =item pending -- pending state of the bug; one of following possible
1144 values; values listed later have precedence if multiple conditions are
1149 =item pending -- default state
1151 =item forwarded -- bug has been forwarded
1153 =item pending-fixed -- bug is tagged pending
1155 =item fixed -- bug is tagged fixed
1157 =item absent -- bug does not apply to this distribution/architecture
1159 =item done -- bug is resolved in this distribution/architecture
1163 =item location -- db-h or archive; the location in the filesystem
1165 =item subject -- title of the bug
1167 =item last_modified -- epoch that the bug was last modified
1169 =item date -- epoch that the bug was filed
1171 =item originator -- bug reporter
1173 =item log_modified -- epoch that the log file was last modified
1175 =item msgid -- Message id of the original bug report
1180 Other key/value pairs are returned but are not currently documented here.
1184 sub get_bug_status {
1188 my %param = validate_with(params => \@_,
1189 spec => {bug => {type => SCALAR,
1192 status => {type => HASHREF,
1195 bug_index => {type => OBJECT,
1198 version => {type => SCALAR|ARRAYREF,
1201 dist => {type => SCALAR|ARRAYREF,
1204 arch => {type => SCALAR|ARRAYREF,
1207 bugusertags => {type => HASHREF,
1210 sourceversions => {type => ARRAYREF,
1213 indicatesource => {type => BOOLEAN,
1220 if (defined $param{bug_index} and
1221 exists $param{bug_index}{$param{bug}}) {
1222 %status = %{ $param{bug_index}{$param{bug}} };
1223 $status{pending} = $status{ status };
1224 $status{id} = $param{bug};
1227 if (defined $param{status}) {
1228 %status = %{$param{status}};
1231 my $location = getbuglocation($param{bug}, 'summary');
1232 return {} if not defined $location or not length $location;
1233 %status = %{ readbug( $param{bug}, $location ) };
1235 $status{id} = $param{bug};
1237 if (defined $param{bugusertags}{$param{bug}}) {
1238 $status{keywords} = "" unless defined $status{keywords};
1239 $status{keywords} .= " " unless $status{keywords} eq "";
1240 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1242 $status{tags} = $status{keywords};
1243 my %tags = map { $_ => 1 } split ' ', $status{tags};
1245 $status{package} = '' if not defined $status{package};
1246 $status{"package"} =~ s/\s*$//;
1248 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1252 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1253 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1255 $status{"pending"} = 'pending';
1256 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1257 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1258 $status{"pending"} = 'fixed' if ($tags{fixed});
1261 my $presence = bug_presence(status => \%status,
1262 map{(exists $param{$_})?($_,$param{$_}):()}
1263 qw(bug sourceversions arch dist version found fixed package)
1265 if (defined $presence) {
1266 if ($presence eq 'fixed') {
1267 $status{pending} = 'done';
1269 elsif ($presence eq 'absent') {
1270 $status{pending} = 'absent';
1278 my $precence = bug_presence(bug => nnn,
1282 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1283 is found, absent, fixed, or no information is available in the
1284 distribution (dist) and/or architecture (arch) specified.
1291 =item bug -- scalar bug number
1293 =item status -- optional hashref of bug status as returned by readbug
1294 (can be passed to avoid rereading the bug information)
1296 =item bug_index -- optional tied index of bug status infomration;
1297 currently not correctly implemented.
1299 =item version -- optional version to check package status at
1301 =item dist -- optional distribution to check package status at
1303 =item arch -- optional architecture to check package status at
1305 =item sourceversion -- optional arrayref of source/version; overrides
1306 dist, arch, and version. [The entries in this array must be in the
1307 "source/version" format.] Eventually this can be used to for caching.
1314 my %param = validate_with(params => \@_,
1315 spec => {bug => {type => SCALAR,
1318 status => {type => HASHREF,
1321 version => {type => SCALAR|ARRAYREF,
1324 dist => {type => SCALAR|ARRAYREF,
1327 arch => {type => SCALAR|ARRAYREF,
1330 sourceversions => {type => ARRAYREF,
1336 if (defined $param{status}) {
1337 %status = %{$param{status}};
1340 my $location = getbuglocation($param{bug}, 'summary');
1341 return {} if not length $location;
1342 %status = %{ readbug( $param{bug}, $location ) };
1346 my $pseudo_desc = getpseudodesc();
1347 if (not exists $param{sourceversions}) {
1349 # pseudopackages do not have source versions by definition.
1350 if (exists $pseudo_desc->{$status{package}}) {
1353 elsif (defined $param{version}) {
1354 foreach my $arch (make_list($param{arch})) {
1355 for my $package (split /\s*,\s*/, $status{package}) {
1356 my @temp = makesourceversions($package,
1358 make_list($param{version})
1360 @sourceversions{@temp} = (1) x @temp;
1363 } elsif (defined $param{dist}) {
1364 my %affects_distribution_tags;
1365 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1366 (1) x @{$config{affects_distribution_tags}};
1367 my $some_distributions_disallowed = 0;
1368 my %allowed_distributions;
1369 for my $tag (split ' ', ($status{keywords}||'')) {
1370 if (exists $config{distribution_aliases}{$tag} and
1371 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1372 $some_distributions_disallowed = 1;
1373 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1375 elsif (exists $affects_distribution_tags{$tag}) {
1376 $some_distributions_disallowed = 1;
1377 $allowed_distributions{$tag} = 1;
1380 my @archs = make_list(exists $param{arch}?$param{arch}:());
1381 GET_SOURCE_VERSIONS:
1382 foreach my $arch (@archs) {
1383 for my $package (split /\s*,\s*/, $status{package}) {
1386 if ($package =~ /^src:(.+)$/) {
1390 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1391 # if some distributions are disallowed,
1392 # and this isn't an allowed
1393 # distribution, then we ignore this
1394 # distribution for the purposees of
1396 if ($some_distributions_disallowed and
1397 not exists $allowed_distributions{$dist}) {
1400 push @versions, get_versions(package => $package,
1402 ($source?(arch => 'source'):
1403 (defined $arch?(arch => $arch):())),
1406 next unless @versions;
1407 my @temp = make_source_versions(package => $package,
1409 versions => \@versions,
1411 @sourceversions{@temp} = (1) x @temp;
1414 # this should really be split out into a subroutine,
1415 # but it'd touch so many things currently, that we fake
1416 # it; it's needed to properly handle bugs which are
1417 # erroneously assigned to the binary package, and we'll
1418 # probably have it go away eventually.
1419 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1421 goto GET_SOURCE_VERSIONS;
1425 # TODO: This should probably be handled further out for efficiency and
1426 # for more ease of distinguishing between pkg= and src= queries.
1427 # DLA: src= queries should just pass arch=source, and they'll be happy.
1428 @sourceversions = keys %sourceversions;
1431 @sourceversions = @{$param{sourceversions}};
1433 my $maxbuggy = 'undef';
1434 if (@sourceversions) {
1435 $maxbuggy = max_buggy(bug => $param{bug},
1436 sourceversions => \@sourceversions,
1437 found => $status{found_versions},
1438 fixed => $status{fixed_versions},
1439 package => $status{package},
1440 version_cache => $version_cache,
1443 elsif (defined $param{dist} and
1444 not exists $pseudo_desc->{$status{package}}) {
1447 if (length($status{done}) and
1448 (not @sourceversions or not @{$status{fixed_versions}})) {
1463 =item bug -- scalar bug number
1465 =item sourceversion -- optional arrayref of source/version; overrides
1466 dist, arch, and version. [The entries in this array must be in the
1467 "source/version" format.] Eventually this can be used to for caching.
1471 Note: Currently the version information is cached; this needs to be
1472 changed before using this function in long lived programs.
1477 my %param = validate_with(params => \@_,
1478 spec => {bug => {type => SCALAR,
1481 sourceversions => {type => ARRAYREF,
1484 found => {type => ARRAYREF,
1487 fixed => {type => ARRAYREF,
1490 package => {type => SCALAR,
1492 version_cache => {type => HASHREF,
1497 # Resolve bugginess states (we might be looking at multiple
1498 # architectures, say). Found wins, then fixed, then absent.
1499 my $maxbuggy = 'absent';
1500 for my $package (split /\s*,\s*/, $param{package}) {
1501 for my $version (@{$param{sourceversions}}) {
1502 my $buggy = buggy(bug => $param{bug},
1503 version => $version,
1504 found => $param{found},
1505 fixed => $param{fixed},
1506 version_cache => $param{version_cache},
1507 package => $package,
1509 if ($buggy eq 'found') {
1511 } elsif ($buggy eq 'fixed') {
1512 $maxbuggy = 'fixed';
1529 Returns the output of Debbugs::Versions::buggy for a particular
1530 package, version and found/fixed set. Automatically turns found, fixed
1531 and version into source/version strings.
1533 Caching can be had by using the version_cache, but no attempt to check
1534 to see if the on disk information is more recent than the cache is
1535 made. [This will need to be fixed for long-lived processes.]
1540 my %param = validate_with(params => \@_,
1541 spec => {bug => {type => SCALAR,
1544 found => {type => ARRAYREF,
1547 fixed => {type => ARRAYREF,
1550 version_cache => {type => HASHREF,
1553 package => {type => SCALAR,
1555 version => {type => SCALAR,
1559 my @found = @{$param{found}};
1560 my @fixed = @{$param{fixed}};
1561 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1562 # We have non-source version versions
1563 @found = makesourceversions($param{package},undef,
1566 @fixed = makesourceversions($param{package},undef,
1570 if ($param{version} !~ m{/}) {
1571 my ($version) = makesourceversions($param{package},undef,
1574 $param{version} = $version if defined $version;
1576 # Figure out which source packages we need
1578 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1579 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1580 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1581 $param{version} =~ m{/};
1583 if (not defined $param{version_cache} or
1584 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1585 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1586 foreach my $source (keys %sources) {
1587 my $srchash = substr $source, 0, 1;
1588 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1589 if (not defined $version_fh) {
1590 # We only want to warn if it's a package which actually has a maintainer
1591 my $maints = getmaintainers();
1592 next if not exists $maints->{$source};
1593 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1596 $version->load($version_fh);
1598 if (defined $param{version_cache}) {
1599 $param{version_cache}{join(',',sort keys %sources)} = $version;
1603 $version = $param{version_cache}{join(',',sort keys %sources)};
1605 return $version->buggy($param{version},\@found,\@fixed);
1608 sub isstrongseverity {
1609 my $severity = shift;
1610 $severity = $config{default_severity} if
1611 not defined $severity or $severity eq '';
1612 return grep { $_ eq $severity } @{$config{strong_severities}};
1617 =head2 generate_index_db_line
1619 my $data = read_bug(bug => $bug,
1620 location => $initialdir);
1621 # generate_index_db_line hasn't been written yet at all.
1622 my $line = generate_index_db_line($data);
1624 Returns a line for a bug suitable to be written out to index.db.
1628 sub generate_index_db_line {
1629 my ($data,$bug) = @_;
1631 # just in case someone has given us a split out data
1632 $data = join_status_fields($data);
1634 my $whendone = "open";
1635 my $severity = $config{default_severity};
1636 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1637 $pkglist =~ s/^,+//;
1638 $pkglist =~ s/,+$//;
1639 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1640 $whendone = "done" if defined $data->{done} and length $data->{done};
1641 $severity = $data->{severity} if length $data->{severity};
1642 return sprintf "%s %d %d %s [%s] %s %s\n",
1643 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1644 $data->{originator}, $severity, $data->{keywords};
1649 =head1 PRIVATE FUNCTIONS
1653 sub update_realtime {
1654 my ($file, %bugs) = @_;
1656 # update realtime index.db
1658 return () unless keys %bugs;
1659 my $idx_old = IO::File->new($file,'r')
1660 or die "Couldn't open ${file}: $!";
1661 my $idx_new = IO::File->new($file.'.new','w')
1662 or die "Couldn't open ${file}.new: $!";
1664 binmode($idx_old,':raw:utf8');
1665 binmode($idx_new,':raw:encoding(UTF-8)');
1666 my $min_bug = min(keys %bugs);
1670 while($line = <$idx_old>) {
1671 @line = split /\s/, $line;
1672 # Two cases; replacing existing line or adding new line
1673 if (exists $bugs{$line[1]}) {
1674 my $new = $bugs{$line[1]};
1675 delete $bugs{$line[1]};
1676 $min_bug = min(keys %bugs);
1677 if ($new eq "NOCHANGE") {
1678 print {$idx_new} $line;
1679 $changed_bugs{$line[1]} = $line;
1680 } elsif ($new eq "REMOVE") {
1681 $changed_bugs{$line[1]} = $line;
1683 print {$idx_new} $new;
1684 $changed_bugs{$line[1]} = $line;
1688 while ($line[1] > $min_bug) {
1689 print {$idx_new} $bugs{$min_bug};
1690 delete $bugs{$min_bug};
1691 last unless keys %bugs;
1692 $min_bug = min(keys %bugs);
1694 print {$idx_new} $line;
1696 last unless keys %bugs;
1698 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1700 print {$idx_new} <$idx_old>;
1705 rename("$file.new", $file);
1707 return %changed_bugs;
1710 sub bughook_archive {
1712 filelock("$config{spool_dir}/debbugs.trace.lock");
1713 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1714 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1715 map{($_,'REMOVE')} @refs);
1716 update_realtime("$config{spool_dir}/index.archive.realtime",
1722 my ( $type, %bugs_temp ) = @_;
1723 filelock("$config{spool_dir}/debbugs.trace.lock");
1726 for my $bug (keys %bugs_temp) {
1727 my $data = $bugs_temp{$bug};
1728 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1730 $bugs{$bug} = generate_index_db_line($data,$bug);
1732 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);