1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Status;
14 Debbugs::Status -- Routines for dealing with summary and status files
23 This module is a replacement for the parts of errorlib.pl which write
24 and read status and summary files.
26 It also contains generic routines for returning information about the
27 status of a particular bug
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(:util :lock :quit :misc);
41 use Debbugs::Config qw(:config);
42 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
43 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
44 use Debbugs::Versions;
45 use Debbugs::Versions::Dpkg;
47 use File::Copy qw(copy);
48 use Encode qw(decode encode);
50 use Storable qw(dclone);
51 use List::Util qw(min max);
57 $DEBUG = 0 unless defined $DEBUG;
60 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
61 qw(isstrongseverity bug_presence split_status_fields),
63 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
64 qw(lock_read_all_merged_bugs),
66 write => [qw(writebug makestatus unlockwritebug)],
68 versions => [qw(addfoundversions addfixedversions),
69 qw(removefoundversions removefixedversions)
71 hook => [qw(bughook bughook_archive)],
72 fields => [qw(%fields)],
75 Exporter::export_ok_tags(keys %EXPORT_TAGS);
76 $EXPORT_TAGS{all} = [@EXPORT_OK];
82 readbug($bug_num,$location)
85 Reads a summary file from the archive given a bug number and a bug
86 location. Valid locations are those understood by L</getbugcomponent>
90 # these probably shouldn't be imported by most people, but
91 # Debbugs::Control needs them, so they're now exportable
92 our %fields = (originator => 'submitter',
95 msgid => 'message-id',
96 'package' => 'package',
99 forwarded => 'forwarded-to',
100 mergedwith => 'merged-with',
101 severity => 'severity',
103 found_versions => 'found-in',
104 found_date => 'found-date',
105 fixed_versions => 'fixed-in',
106 fixed_date => 'fixed-date',
108 blockedby => 'blocked-by',
109 unarchived => 'unarchived',
110 summary => 'summary',
111 affects => 'affects',
115 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
116 my @rfc1522_fields = qw(originator subject done forwarded owner);
119 return read_bug(bug => $_[0],
120 (@_ > 1)?(location => $_[1]):()
126 read_bug(bug => $bug_num,
127 location => 'archive',
129 read_bug(summary => 'path/to/bugnum.summary');
132 A more complete function than readbug; it enables you to pass a full
133 path to the summary file instead of the bug number and/or location.
139 =item bug -- the bug number
141 =item location -- optional location which is passed to getbugcomponent
143 =item summary -- complete path to the .summary file which will be read
145 =item lock -- whether to obtain a lock for the bug to prevent
146 something modifying it while the bug has been read. You B<must> call
147 C<unfilelock();> if something not undef is returned from read_bug.
149 =item locks -- hashref of already obtained locks; incremented as new
150 locks are needed, and decremented as locks are released on particular
155 One of C<bug> or C<summary> must be passed. This function will return
156 undef on failure, and will die if improper arguments are passed.
164 my %param = validate_with(params => \@_,
165 spec => {bug => {type => SCALAR,
169 # negative bugnumbers
172 location => {type => SCALAR|UNDEF,
175 summary => {type => SCALAR,
178 lock => {type => BOOLEAN,
181 locks => {type => HASHREF,
186 die "One of bug or summary must be passed to read_bug"
187 if not exists $param{bug} and not exists $param{summary};
191 if (not defined $param{summary}) {
193 ($lref,$location) = @param{qw(bug location)};
194 if (not defined $location) {
195 $location = getbuglocation($lref,'summary');
196 return undef if not defined $location;
198 $status = getbugcomponent($lref, 'summary', $location);
199 $log = getbugcomponent($lref, 'log' , $location);
200 return undef unless defined $status;
201 return undef if not -e $status;
204 $status = $param{summary};
206 $log =~ s/\.summary$/.log/;
207 ($location) = $status =~ m/(db-h|db|archive)/;
210 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
212 my $status_fh = IO::File->new($status, 'r');
213 if (not defined $status_fh) {
214 warn "Unable to open $status for reading: $!";
216 unfilelock(exists $param{locks}?$param{locks}:());
226 while (<$status_fh>) {
229 $version = $1 if /^Format-Version: ([0-9]+)/i;
232 # Version 3 is the latest format version currently supported.
234 warn "Unsupported status version '$version'";
236 unfilelock(exists $param{locks}?$param{locks}:());
241 my %namemap = reverse %fields;
242 for my $line (@lines) {
243 my @encodings_to_try = qw(utf8 iso8859-1);
245 @encodings_to_try = qw(utf8);
247 for (@encodings_to_try) {
250 $temp = decode("$_",$line,Encode::FB_CROAK);
252 if (not $@) { # only update the line if there are no errors.
257 if ($line =~ /(\S+?): (.*)/) {
258 my ($name, $value) = (lc $1, $2);
259 # this is a bit of a hack; we should never, ever have \r
260 # or \n in the fields of status. Kill them off here.
261 # [Eventually, this should be superfluous.]
262 $value =~ s/[\r\n]//g;
263 $data{$namemap{$name}} = $value if exists $namemap{$name};
266 for my $field (keys %fields) {
267 $data{$field} = '' unless exists $data{$field};
270 for my $field (@rfc1522_fields) {
271 $data{$field} = decode_rfc1522($data{$field});
274 $data{severity} = $config{default_severity} if $data{severity} eq '';
275 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
276 $data{$field} = [split ' ', $data{$field}];
278 for my $field (qw(found fixed)) {
279 # create the found/fixed hashes which indicate when a
280 # particular version was marked found or marked fixed.
281 @{$data{$field}}{@{$data{"${field}_versions"}}} =
282 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
283 @{$data{"${field}_date"}});
286 my $status_modified = (stat($status))[9];
287 # Add log last modified time
288 $data{log_modified} = (stat($log))[9];
289 $data{last_modified} = max($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 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } @bugs);
525 if ($newdata->{mergedwith} ne $expectmerge) {
527 unfilelock(exists $param{locks}?$param{locks}:());
529 die "Bug $param{bug} differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
533 return ($locks,@data);
538 my $new_bug_num = new_bug(copy => $data->{bug_num});
540 Creates a new bug and returns the new bug number upon success.
548 validate_with(params => \@_,
549 spec => {copy => {type => SCALAR,
555 filelock("nextnumber.lock");
556 my $nn_fh = IO::File->new("nextnumber",'r') or
557 die "Unable to open nextnuber for reading: $!";
560 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
562 overwritefile("nextnumber",
565 my $nn_hash = get_hashname($nn);
567 my $c_hash = get_hashname($param{copy});
568 for my $file (qw(log status summary report)) {
569 copy("db-h/$c_hash/$param{copy}.$file",
570 "db-h/$nn_hash/${nn}.$file")
574 for my $file (qw(log status summary report)) {
575 overwritefile("db-h/$nn_hash/${nn}.$file",
580 # this probably needs to be munged to do something more elegant
581 # &bughook('new', $clone, $data);
588 my @v1fieldorder = qw(originator date subject msgid package
589 keywords done forwarded mergedwith severity);
593 my $content = makestatus($status,$version)
594 my $content = makestatus($status);
596 Creates the content for a status file based on the $status hashref
599 Really only useful for writebug
601 Currently defaults to version 2 (non-encoded rfc1522 names) but will
602 eventually default to version 3. If you care, you should specify a
608 my ($data,$version) = @_;
609 $version = 3 unless defined $version;
613 my %newdata = %$data;
614 for my $field (qw(found fixed)) {
615 if (exists $newdata{$field}) {
616 $newdata{"${field}_date"} =
617 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
620 %newdata = %{join_status_fields(\%newdata)};
623 for my $field (@rfc1522_fields) {
624 $newdata{$field} = encode_rfc1522($newdata{$field});
628 # this is a bit of a hack; we should never, ever have \r or \n in
629 # the fields of status. Kill them off here. [Eventually, this
630 # should be superfluous.]
631 for my $field (keys %newdata) {
632 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
636 for my $field (@v1fieldorder) {
637 if (exists $newdata{$field} and defined $newdata{$field}) {
638 $contents .= "$newdata{$field}\n";
643 } elsif ($version == 2 or $version == 3) {
644 # Version 2 or 3. Add a file format version number for the sake of
645 # further extensibility in the future.
646 $contents .= "Format-Version: $version\n";
647 for my $field (keys %fields) {
648 if (exists $newdata{$field} and defined $newdata{$field}
649 and $newdata{$field} ne '') {
650 # Output field names in proper case, e.g. 'Merged-With'.
651 my $properfield = $fields{$field};
652 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
653 my $data = $newdata{$field};
654 $contents .= "$properfield: $data\n";
660 $contents = encode_utf8($contents,Encode::FB_CROAK);
668 writebug($bug_num,$status,$location,$minversion,$disablebughook)
670 Writes the bug status and summary files out.
672 Skips writting out a status file if minversion is 2
674 Does not call bughook if disablebughook is true.
679 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
682 my %outputs = (1 => 'status', 3 => 'summary');
683 for my $version (keys %outputs) {
684 next if defined $minversion and $version < $minversion;
685 my $status = getbugcomponent($ref, $outputs{$version}, $location);
686 die "can't find location for $ref" unless defined $status;
689 open $sfh,">:utf8","$status.new" or
690 die "opening $status.new: $!";
693 open $sfh,">","$status.new" or
694 die "opening $status.new: $!";
696 print {$sfh} makestatus($data, $version) or
697 die "writing $status.new: $!";
698 close($sfh) or die "closing $status.new: $!";
704 rename("$status.new",$status) || die "installing new $status: $!";
707 # $disablebughook is a bit of a hack to let format migration scripts use
708 # this function rather than having to duplicate it themselves.
709 &bughook($change,$ref,$data) unless $disablebughook;
712 =head2 unlockwritebug
714 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
716 Writes a bug, then calls unfilelock; see writebug for what these
728 The following functions are exported with the :versions tag
730 =head2 addfoundversions
732 addfoundversions($status,$package,$version,$isbinary);
734 All use of this should be phased out in favor of Debbugs::Control::fixed/found
739 sub addfoundversions {
743 my $isbinary = shift;
744 return unless defined $version;
745 undef $package if $package =~ m[(?:\s|/)];
746 my $source = $package;
747 if ($package =~ s/^src://) {
752 if (defined $package and $isbinary) {
753 my @srcinfo = binary_to_source(binary => $package,
754 version => $version);
756 # We know the source package(s). Use a fully-qualified version.
757 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
760 # Otherwise, an unqualified version will have to do.
764 # Strip off various kinds of brain-damage.
766 $version =~ s/ *\(.*\)//;
767 $version =~ s/ +[A-Za-z].*//;
769 foreach my $ver (split /[,\s]+/, $version) {
770 my $sver = defined($source) ? "$source/$ver" : '';
771 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
772 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
774 @{$data->{fixed_versions}} =
775 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
779 =head2 removefoundversions
781 removefoundversions($data,$package,$versiontoremove)
783 Removes found versions from $data
785 If a version is fully qualified (contains /) only versions matching
786 exactly are removed. Otherwise, all versions matching the version
789 Currently $package and $isbinary are entirely ignored, but accepted
790 for backwards compatibilty.
794 sub removefoundversions {
798 my $isbinary = shift;
799 return unless defined $version;
801 foreach my $ver (split /[,\s]+/, $version) {
803 # fully qualified version
804 @{$data->{found_versions}} =
806 @{$data->{found_versions}};
809 # non qualified version; delete all matchers
810 @{$data->{found_versions}} =
811 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
812 @{$data->{found_versions}};
818 sub addfixedversions {
822 my $isbinary = shift;
823 return unless defined $version;
824 undef $package if defined $package and $package =~ m[(?:\s|/)];
825 my $source = $package;
827 if (defined $package and $isbinary) {
828 my @srcinfo = binary_to_source(binary => $package,
829 version => $version);
831 # We know the source package(s). Use a fully-qualified version.
832 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
835 # Otherwise, an unqualified version will have to do.
839 # Strip off various kinds of brain-damage.
841 $version =~ s/ *\(.*\)//;
842 $version =~ s/ +[A-Za-z].*//;
844 foreach my $ver (split /[,\s]+/, $version) {
845 my $sver = defined($source) ? "$source/$ver" : '';
846 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
847 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
849 @{$data->{found_versions}} =
850 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
854 sub removefixedversions {
858 my $isbinary = shift;
859 return unless defined $version;
861 foreach my $ver (split /[,\s]+/, $version) {
863 # fully qualified version
864 @{$data->{fixed_versions}} =
866 @{$data->{fixed_versions}};
869 # non qualified version; delete all matchers
870 @{$data->{fixed_versions}} =
871 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
872 @{$data->{fixed_versions}};
883 Split a package string from the status file into a list of package names.
889 return unless defined $pkgs;
890 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
894 =head2 bug_archiveable
896 bug_archiveable(bug => $bug_num);
902 =item bug -- bug number (required)
904 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
906 =item version -- Debbugs::Version information (optional)
908 =item days_until -- return days until the bug can be archived
912 Returns 1 if the bug can be archived
913 Returns 0 if the bug cannot be archived
915 If days_until is true, returns the number of days until the bug can be
916 archived, -1 if it cannot be archived. 0 means that the bug can be
917 archived the next time the archiver runs.
919 Returns undef on failure.
923 # This will eventually need to be fixed before we start using mod_perl
924 our $version_cache = {};
926 my %param = validate_with(params => \@_,
927 spec => {bug => {type => SCALAR,
930 status => {type => HASHREF,
933 days_until => {type => BOOLEAN,
936 ignore_time => {type => BOOLEAN,
941 # This is what we return if the bug cannot be archived.
942 my $cannot_archive = $param{days_until}?-1:0;
943 # read the status information
944 my $status = $param{status};
945 if (not exists $param{status} or not defined $status) {
946 $status = read_bug(bug=>$param{bug});
947 if (not defined $status) {
948 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
952 # Bugs can be archived if they are
954 if (not defined $status->{done} or not length $status->{done}) {
955 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
956 return $cannot_archive
958 # Check to make sure that the bug has none of the unremovable tags set
959 if (@{$config{removal_unremovable_tags}}) {
960 for my $tag (split ' ', ($status->{keywords}||'')) {
961 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
962 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
963 return $cannot_archive;
968 # If we just are checking if the bug can be archived, we'll not even bother
969 # checking the versioning information if the bug has been -done for less than 28 days.
970 my $log_file = getbugcomponent($param{bug},'log');
971 if (not defined $log_file) {
972 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
973 return $cannot_archive;
975 my $max_log_age = max(map {$config{remove_age} - -M $_}
976 $log_file, map {my $log = getbugcomponent($_,'log');
977 defined $log ? ($log) : ();
979 split / /, $status->{mergedwith}
981 if (not $param{days_until} and not $param{ignore_time}
984 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
985 return $cannot_archive;
987 # At this point, we have to get the versioning information for this bug.
988 # We examine the set of distribution tags. If a bug has no distribution
989 # tags set, we assume a default set, otherwise we use the tags the bug
992 # In cases where we are assuming a default set, if the severity
993 # is strong, we use the strong severity default; otherwise, we
994 # use the normal default.
996 # There must be fixed_versions for us to look at the versioning
998 my $min_fixed_time = time;
999 my $min_archive_days = 0;
1000 if (@{$status->{fixed_versions}}) {
1002 @dist_tags{@{$config{removal_distribution_tags}}} =
1003 (1) x @{$config{removal_distribution_tags}};
1005 for my $tag (split ' ', ($status->{keywords}||'')) {
1006 next unless exists $config{distribution_aliases}{$tag};
1007 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1008 $dists{$config{distribution_aliases}{$tag}} = 1;
1010 if (not keys %dists) {
1011 if (isstrongseverity($status->{severity})) {
1012 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1013 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1016 @dists{@{$config{removal_default_distribution_tags}}} =
1017 (1) x @{$config{removal_default_distribution_tags}};
1020 my %source_versions;
1021 my @sourceversions = get_versions(package => $status->{package},
1022 dist => [keys %dists],
1025 @source_versions{@sourceversions} = (1) x @sourceversions;
1026 # If the bug has not been fixed in the versions actually
1027 # distributed, then it cannot be archived.
1028 if ('found' eq max_buggy(bug => $param{bug},
1029 sourceversions => [keys %source_versions],
1030 found => $status->{found_versions},
1031 fixed => $status->{fixed_versions},
1032 version_cache => $version_cache,
1033 package => $status->{package},
1035 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1036 return $cannot_archive;
1038 # Since the bug has at least been fixed in the architectures
1039 # that matters, we check to see how long it has been fixed.
1041 # If $param{ignore_time}, then we should ignore time.
1042 if ($param{ignore_time}) {
1043 return $param{days_until}?0:1;
1046 # To do this, we order the times from most recent to oldest;
1047 # when we come to the first found version, we stop.
1048 # If we run out of versions, we only report the time of the
1050 my %time_versions = get_versions(package => $status->{package},
1051 dist => [keys %dists],
1055 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1056 my $buggy = buggy(bug => $param{bug},
1057 version => $version,
1058 found => $status->{found_versions},
1059 fixed => $status->{fixed_versions},
1060 version_cache => $version_cache,
1061 package => $status->{package},
1063 last if $buggy eq 'found';
1064 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1066 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1067 # if there are no versions in the archive at all, then
1068 # we can archive if enough days have passed
1071 # If $param{ignore_time}, then we should ignore time.
1072 if ($param{ignore_time}) {
1073 return $param{days_until}?0:1;
1075 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1076 my $age = ceil($max_log_age);
1077 if ($age > 0 or $min_archive_days > 0) {
1078 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1079 return $param{days_until}?max($age,$min_archive_days):0;
1082 return $param{days_until}?0:1;
1087 =head2 get_bug_status
1089 my $status = get_bug_status(bug => $nnn);
1091 my $status = get_bug_status($bug_num)
1097 =item bug -- scalar bug number
1099 =item status -- optional hashref of bug status as returned by readbug
1100 (can be passed to avoid rereading the bug information)
1102 =item bug_index -- optional tied index of bug status infomration;
1103 currently not correctly implemented.
1105 =item version -- optional version(s) to check package status at
1107 =item dist -- optional distribution(s) to check package status at
1109 =item arch -- optional architecture(s) to check package status at
1111 =item bugusertags -- optional hashref of bugusertags
1113 =item sourceversion -- optional arrayref of source/version; overrides
1114 dist, arch, and version. [The entries in this array must be in the
1115 "source/version" format.] Eventually this can be used to for caching.
1117 =item indicatesource -- if true, indicate which source packages this
1118 bug could belong to (or does belong to in the case of bugs assigned to
1119 a source package). Defaults to true.
1123 Note: Currently the version information is cached; this needs to be
1124 changed before using this function in long lived programs.
1128 sub get_bug_status {
1132 my %param = validate_with(params => \@_,
1133 spec => {bug => {type => SCALAR,
1136 status => {type => HASHREF,
1139 bug_index => {type => OBJECT,
1142 version => {type => SCALAR|ARRAYREF,
1145 dist => {type => SCALAR|ARRAYREF,
1148 arch => {type => SCALAR|ARRAYREF,
1151 bugusertags => {type => HASHREF,
1154 sourceversions => {type => ARRAYREF,
1157 indicatesource => {type => BOOLEAN,
1164 if (defined $param{bug_index} and
1165 exists $param{bug_index}{$param{bug}}) {
1166 %status = %{ $param{bug_index}{$param{bug}} };
1167 $status{pending} = $status{ status };
1168 $status{id} = $param{bug};
1171 if (defined $param{status}) {
1172 %status = %{$param{status}};
1175 my $location = getbuglocation($param{bug}, 'summary');
1176 return {} if not defined $location or not length $location;
1177 %status = %{ readbug( $param{bug}, $location ) };
1179 $status{id} = $param{bug};
1181 if (defined $param{bugusertags}{$param{bug}}) {
1182 $status{keywords} = "" unless defined $status{keywords};
1183 $status{keywords} .= " " unless $status{keywords} eq "";
1184 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1186 $status{tags} = $status{keywords};
1187 my %tags = map { $_ => 1 } split ' ', $status{tags};
1189 $status{package} = '' if not defined $status{package};
1190 $status{"package"} =~ s/\s*$//;
1192 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1196 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1197 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1199 $status{"pending"} = 'pending';
1200 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1201 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1202 $status{"pending"} = 'fixed' if ($tags{fixed});
1205 my $presence = bug_presence(status => \%status,
1206 map{(exists $param{$_})?($_,$param{$_}):()}
1207 qw(bug sourceversions arch dist version found fixed package)
1209 if (defined $presence) {
1210 if ($presence eq 'fixed') {
1211 $status{pending} = 'done';
1213 elsif ($presence eq 'absent') {
1214 $status{pending} = 'absent';
1222 my $precence = bug_presence(bug => nnn,
1226 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1227 is found, absent, fixed, or no information is available in the
1228 distribution (dist) and/or architecture (arch) specified.
1235 =item bug -- scalar bug number
1237 =item status -- optional hashref of bug status as returned by readbug
1238 (can be passed to avoid rereading the bug information)
1240 =item bug_index -- optional tied index of bug status infomration;
1241 currently not correctly implemented.
1243 =item version -- optional version to check package status at
1245 =item dist -- optional distribution to check package status at
1247 =item arch -- optional architecture to check package status at
1249 =item sourceversion -- optional arrayref of source/version; overrides
1250 dist, arch, and version. [The entries in this array must be in the
1251 "source/version" format.] Eventually this can be used to for caching.
1258 my %param = validate_with(params => \@_,
1259 spec => {bug => {type => SCALAR,
1262 status => {type => HASHREF,
1265 version => {type => SCALAR|ARRAYREF,
1268 dist => {type => SCALAR|ARRAYREF,
1271 arch => {type => SCALAR|ARRAYREF,
1274 sourceversions => {type => ARRAYREF,
1280 if (defined $param{status}) {
1281 %status = %{$param{status}};
1284 my $location = getbuglocation($param{bug}, 'summary');
1285 return {} if not length $location;
1286 %status = %{ readbug( $param{bug}, $location ) };
1290 my $pseudo_desc = getpseudodesc();
1291 if (not exists $param{sourceversions}) {
1293 # pseudopackages do not have source versions by definition.
1294 if (exists $pseudo_desc->{$status{package}}) {
1297 elsif (defined $param{version}) {
1298 foreach my $arch (make_list($param{arch})) {
1299 for my $package (split /\s*,\s*/, $status{package}) {
1300 my @temp = makesourceversions($package,
1302 make_list($param{version})
1304 @sourceversions{@temp} = (1) x @temp;
1307 } elsif (defined $param{dist}) {
1308 my %affects_distribution_tags;
1309 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1310 (1) x @{$config{affects_distribution_tags}};
1311 my $some_distributions_disallowed = 0;
1312 my %allowed_distributions;
1313 for my $tag (split ' ', ($status{keywords}||'')) {
1314 if (exists $config{distribution_aliases}{$tag} and
1315 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1316 $some_distributions_disallowed = 1;
1317 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1319 elsif (exists $affects_distribution_tags{$tag}) {
1320 $some_distributions_disallowed = 1;
1321 $allowed_distributions{$tag} = 1;
1324 my @archs = make_list(exists $param{arch}?$param{arch}:());
1325 GET_SOURCE_VERSIONS:
1326 foreach my $arch (@archs) {
1327 for my $package (split /\s*,\s*/, $status{package}) {
1330 if ($package =~ /^src:(.+)$/) {
1334 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1335 # if some distributions are disallowed,
1336 # and this isn't an allowed
1337 # distribution, then we ignore this
1338 # distribution for the purposees of
1340 if ($some_distributions_disallowed and
1341 not exists $allowed_distributions{$dist}) {
1344 push @versions, get_versions(package => $package,
1346 ($source?(arch => 'source'):
1347 (defined $arch?(arch => $arch):())),
1350 next unless @versions;
1351 my @temp = make_source_versions(package => $package,
1353 versions => \@versions,
1355 @sourceversions{@temp} = (1) x @temp;
1358 # this should really be split out into a subroutine,
1359 # but it'd touch so many things currently, that we fake
1360 # it; it's needed to properly handle bugs which are
1361 # erroneously assigned to the binary package, and we'll
1362 # probably have it go away eventually.
1363 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1365 goto GET_SOURCE_VERSIONS;
1369 # TODO: This should probably be handled further out for efficiency and
1370 # for more ease of distinguishing between pkg= and src= queries.
1371 # DLA: src= queries should just pass arch=source, and they'll be happy.
1372 @sourceversions = keys %sourceversions;
1375 @sourceversions = @{$param{sourceversions}};
1377 my $maxbuggy = 'undef';
1378 if (@sourceversions) {
1379 $maxbuggy = max_buggy(bug => $param{bug},
1380 sourceversions => \@sourceversions,
1381 found => $status{found_versions},
1382 fixed => $status{fixed_versions},
1383 package => $status{package},
1384 version_cache => $version_cache,
1387 elsif (defined $param{dist} and
1388 not exists $pseudo_desc->{$status{package}}) {
1391 if (length($status{done}) and
1392 (not @sourceversions or not @{$status{fixed_versions}})) {
1407 =item bug -- scalar bug number
1409 =item sourceversion -- optional arrayref of source/version; overrides
1410 dist, arch, and version. [The entries in this array must be in the
1411 "source/version" format.] Eventually this can be used to for caching.
1415 Note: Currently the version information is cached; this needs to be
1416 changed before using this function in long lived programs.
1421 my %param = validate_with(params => \@_,
1422 spec => {bug => {type => SCALAR,
1425 sourceversions => {type => ARRAYREF,
1428 found => {type => ARRAYREF,
1431 fixed => {type => ARRAYREF,
1434 package => {type => SCALAR,
1436 version_cache => {type => HASHREF,
1441 # Resolve bugginess states (we might be looking at multiple
1442 # architectures, say). Found wins, then fixed, then absent.
1443 my $maxbuggy = 'absent';
1444 for my $package (split /\s*,\s*/, $param{package}) {
1445 for my $version (@{$param{sourceversions}}) {
1446 my $buggy = buggy(bug => $param{bug},
1447 version => $version,
1448 found => $param{found},
1449 fixed => $param{fixed},
1450 version_cache => $param{version_cache},
1451 package => $package,
1453 if ($buggy eq 'found') {
1455 } elsif ($buggy eq 'fixed') {
1456 $maxbuggy = 'fixed';
1473 Returns the output of Debbugs::Versions::buggy for a particular
1474 package, version and found/fixed set. Automatically turns found, fixed
1475 and version into source/version strings.
1477 Caching can be had by using the version_cache, but no attempt to check
1478 to see if the on disk information is more recent than the cache is
1479 made. [This will need to be fixed for long-lived processes.]
1484 my %param = validate_with(params => \@_,
1485 spec => {bug => {type => SCALAR,
1488 found => {type => ARRAYREF,
1491 fixed => {type => ARRAYREF,
1494 version_cache => {type => HASHREF,
1497 package => {type => SCALAR,
1499 version => {type => SCALAR,
1503 my @found = @{$param{found}};
1504 my @fixed = @{$param{fixed}};
1505 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1506 # We have non-source version versions
1507 @found = makesourceversions($param{package},undef,
1510 @fixed = makesourceversions($param{package},undef,
1514 if ($param{version} !~ m{/}) {
1515 my ($version) = makesourceversions($param{package},undef,
1518 $param{version} = $version if defined $version;
1520 # Figure out which source packages we need
1522 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1523 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1524 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1525 $param{version} =~ m{/};
1527 if (not defined $param{version_cache} or
1528 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1529 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1530 foreach my $source (keys %sources) {
1531 my $srchash = substr $source, 0, 1;
1532 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1533 if (not defined $version_fh) {
1534 # We only want to warn if it's a package which actually has a maintainer
1535 my $maints = getmaintainers();
1536 next if not exists $maints->{$source};
1537 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1540 $version->load($version_fh);
1542 if (defined $param{version_cache}) {
1543 $param{version_cache}{join(',',sort keys %sources)} = $version;
1547 $version = $param{version_cache}{join(',',sort keys %sources)};
1549 return $version->buggy($param{version},\@found,\@fixed);
1552 sub isstrongseverity {
1553 my $severity = shift;
1554 $severity = $config{default_severity} if
1555 not defined $severity or $severity eq '';
1556 return grep { $_ eq $severity } @{$config{strong_severities}};
1560 =head1 PRIVATE FUNCTIONS
1564 sub update_realtime {
1565 my ($file, %bugs) = @_;
1567 # update realtime index.db
1569 return () unless keys %bugs;
1570 my $idx_old = IO::File->new($file,'r')
1571 or die "Couldn't open ${file}: $!";
1572 my $idx_new = IO::File->new($file.'.new','w')
1573 or die "Couldn't open ${file}.new: $!";
1575 my $min_bug = min(keys %bugs);
1579 while($line = <$idx_old>) {
1580 @line = split /\s/, $line;
1581 # Two cases; replacing existing line or adding new line
1582 if (exists $bugs{$line[1]}) {
1583 my $new = $bugs{$line[1]};
1584 delete $bugs{$line[1]};
1585 $min_bug = min(keys %bugs);
1586 if ($new eq "NOCHANGE") {
1587 print {$idx_new} $line;
1588 $changed_bugs{$line[1]} = $line;
1589 } elsif ($new eq "REMOVE") {
1590 $changed_bugs{$line[1]} = $line;
1592 print {$idx_new} $new;
1593 $changed_bugs{$line[1]} = $line;
1597 while ($line[1] > $min_bug) {
1598 print {$idx_new} $bugs{$min_bug};
1599 delete $bugs{$min_bug};
1600 last unless keys %bugs;
1601 $min_bug = min(keys %bugs);
1603 print {$idx_new} $line;
1605 last unless keys %bugs;
1607 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1609 print {$idx_new} <$idx_old>;
1614 rename("$file.new", $file);
1616 return %changed_bugs;
1619 sub bughook_archive {
1621 filelock("$config{spool_dir}/debbugs.trace.lock");
1622 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1623 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1624 map{($_,'REMOVE')} @refs);
1625 update_realtime("$config{spool_dir}/index.archive.realtime",
1631 my ( $type, %bugs_temp ) = @_;
1632 filelock("$config{spool_dir}/debbugs.trace.lock");
1635 for my $bug (keys %bugs_temp) {
1636 my $data = $bugs_temp{$bug};
1637 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1639 my $whendone = "open";
1640 my $severity = $config{default_severity};
1641 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1642 $pkglist =~ s/^,+//;
1643 $pkglist =~ s/,+$//;
1644 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1645 $whendone = "done" if defined $data->{done} and length $data->{done};
1646 $severity = $data->{severity} if length $data->{severity};
1648 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1649 $pkglist, $bug, $data->{date}, $whendone,
1650 $data->{originator}, $severity, $data->{keywords};
1653 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);