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);
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 fields => [qw(%fields)],
76 Exporter::export_ok_tags(keys %EXPORT_TAGS);
77 $EXPORT_TAGS{all} = [@EXPORT_OK];
83 readbug($bug_num,$location)
86 Reads a summary file from the archive given a bug number and a bug
87 location. Valid locations are those understood by L</getbugcomponent>
91 # these probably shouldn't be imported by most people, but
92 # Debbugs::Control needs them, so they're now exportable
93 our %fields = (originator => 'submitter',
96 msgid => 'message-id',
97 'package' => 'package',
100 forwarded => 'forwarded-to',
101 mergedwith => 'merged-with',
102 severity => 'severity',
104 found_versions => 'found-in',
105 found_date => 'found-date',
106 fixed_versions => 'fixed-in',
107 fixed_date => 'fixed-date',
109 blockedby => 'blocked-by',
110 unarchived => 'unarchived',
111 summary => 'summary',
112 outlook => 'outlook',
113 affects => 'affects',
117 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
118 my @rfc1522_fields = qw(originator subject done forwarded owner);
121 return read_bug(bug => $_[0],
122 (@_ > 1)?(location => $_[1]):()
128 read_bug(bug => $bug_num,
129 location => 'archive',
131 read_bug(summary => 'path/to/bugnum.summary');
134 A more complete function than readbug; it enables you to pass a full
135 path to the summary file instead of the bug number and/or location.
141 =item bug -- the bug number
143 =item location -- optional location which is passed to getbugcomponent
145 =item summary -- complete path to the .summary file which will be read
147 =item lock -- whether to obtain a lock for the bug to prevent
148 something modifying it while the bug has been read. You B<must> call
149 C<unfilelock();> if something not undef is returned from read_bug.
151 =item locks -- hashref of already obtained locks; incremented as new
152 locks are needed, and decremented as locks are released on particular
157 One of C<bug> or C<summary> must be passed. This function will return
158 undef on failure, and will die if improper arguments are passed.
166 my %param = validate_with(params => \@_,
167 spec => {bug => {type => SCALAR,
171 # negative bugnumbers
174 location => {type => SCALAR|UNDEF,
177 summary => {type => SCALAR,
180 lock => {type => BOOLEAN,
183 locks => {type => HASHREF,
188 die "One of bug or summary must be passed to read_bug"
189 if not exists $param{bug} and not exists $param{summary};
193 if (not defined $param{summary}) {
195 ($lref,$location) = @param{qw(bug location)};
196 if (not defined $location) {
197 $location = getbuglocation($lref,'summary');
198 return undef if not defined $location;
200 $status = getbugcomponent($lref, 'summary', $location);
201 $log = getbugcomponent($lref, 'log' , $location);
202 return undef unless defined $status;
203 return undef if not -e $status;
206 $status = $param{summary};
208 $log =~ s/\.summary$/.log/;
209 ($location) = $status =~ m/(db-h|db|archive)/;
212 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
214 my $status_fh = IO::File->new($status, 'r');
215 if (not defined $status_fh) {
216 warn "Unable to open $status for reading: $!";
218 unfilelock(exists $param{locks}?$param{locks}:());
222 binmode($status_fh,':encoding(UTF-8)');
229 while (<$status_fh>) {
232 $version = $1 if /^Format-Version: ([0-9]+)/i;
235 # Version 3 is the latest format version currently supported.
237 warn "Unsupported status version '$version'";
239 unfilelock(exists $param{locks}?$param{locks}:());
244 my %namemap = reverse %fields;
245 for my $line (@lines) {
246 if ($line =~ /(\S+?): (.*)/) {
247 my ($name, $value) = (lc $1, $2);
248 # this is a bit of a hack; we should never, ever have \r
249 # or \n in the fields of status. Kill them off here.
250 # [Eventually, this should be superfluous.]
251 $value =~ s/[\r\n]//g;
252 $data{$namemap{$name}} = $value if exists $namemap{$name};
255 for my $field (keys %fields) {
256 $data{$field} = '' unless exists $data{$field};
259 for my $field (@rfc1522_fields) {
260 $data{$field} = decode_rfc1522($data{$field});
263 $data{severity} = $config{default_severity} if $data{severity} eq '';
264 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
265 $data{$field} = [split ' ', $data{$field}];
267 for my $field (qw(found fixed)) {
268 # create the found/fixed hashes which indicate when a
269 # particular version was marked found or marked fixed.
270 @{$data{$field}}{@{$data{"${field}_versions"}}} =
271 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
272 @{$data{"${field}_date"}});
275 my $status_modified = (stat($status))[9];
276 # Add log last modified time
277 $data{log_modified} = (stat($log))[9];
278 $data{last_modified} = max($status_modified,$data{log_modified});
279 $data{location} = $location;
280 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
281 $data{bug_num} = $param{bug};
286 =head2 split_status_fields
288 my @data = split_status_fields(@data);
290 Splits splittable status fields (like package, tags, blocks,
291 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
292 passed @data intact using dclone.
294 In scalar context, returns only the first element of @data.
298 our $ditch_empty = sub{
300 my $splitter = shift @t;
301 return grep {length $_} map {split $splitter} @t;
304 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
306 (package => \&splitpackages,
307 affects => \&splitpackages,
308 blocks => $ditch_empty_space,
309 blockedby => $ditch_empty_space,
310 # this isn't strictly correct, but we'll split both of them for
311 # the time being until we ditch all use of keywords everywhere
313 keywords => $ditch_empty_space,
314 tags => $ditch_empty_space,
315 found_versions => $ditch_empty_space,
316 fixed_versions => $ditch_empty_space,
317 mergedwith => $ditch_empty_space,
320 sub split_status_fields {
321 my @data = @{dclone(\@_)};
322 for my $data (@data) {
323 next if not defined $data;
324 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
325 not (ref($data) and ref($data) eq 'HASH');
326 for my $field (keys %{$data}) {
327 next unless defined $data->{$field};
328 if (exists $split_fields{$field}) {
329 next if ref($data->{$field});
331 if (ref($split_fields{$field}) eq 'CODE') {
332 @elements = &{$split_fields{$field}}($data->{$field});
334 elsif (not ref($split_fields{$field}) or
335 UNIVERSAL::isa($split_fields{$field},'Regex')
337 @elements = split $split_fields{$field}, $data->{$field};
339 $data->{$field} = \@elements;
343 return wantarray?@data:$data[0];
346 =head2 join_status_fields
348 my @data = join_status_fields(@data);
350 Handles joining the splitable status fields. (Basically, the inverse
351 of split_status_fields.
353 Primarily called from makestatus, but may be useful for other
354 functions after calling split_status_fields (or for legacy functions
355 if we transition to split fields by default).
359 sub join_status_fields {
366 found_versions => ' ',
367 fixed_versions => ' ',
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: ".
377 if ref($data) ne 'HASH';
378 for my $field (keys %{$data}) {
379 next unless defined $data->{$field};
380 next unless ref($data->{$field}) eq 'ARRAY';
381 next unless exists $join_fields{$field};
382 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
385 return wantarray?@data:$data[0];
391 lockreadbug($bug_num,$location)
393 Performs a filelock, then reads the bug; the bug is unlocked if the
394 return is undefined, otherwise, you need to call unfilelock or
397 See readbug above for information on what this returns
402 my ($lref, $location) = @_;
403 return read_bug(bug => $lref, location => $location, lock => 1);
406 =head2 lockreadbugmerge
408 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
410 Performs a filelock, then reads the bug. If the bug is merged, locks
411 the merge lock. Returns a list of the number of locks and the bug
416 sub lockreadbugmerge {
417 my ($bug_num,$location) = @_;
418 my $data = lockreadbug(@_);
419 if (not defined $data) {
422 if (not length $data->{mergedwith}) {
426 filelock("$config{spool_dir}/lock/merge");
427 $data = lockreadbug(@_);
428 if (not defined $data) {
435 =head2 lock_read_all_merged_bugs
437 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
439 Performs a filelock, then reads the bug passed. If the bug is merged,
440 locks the merge lock, then reads and locks all of the other merged
441 bugs. Returns a list of the number of locks and the bug data for all
444 Will also return undef if any of the merged bugs failed to be read,
445 even if all of the others were read properly.
449 sub lock_read_all_merged_bugs {
450 my %param = validate_with(params => \@_,
451 spec => {bug => {type => SCALAR,
454 location => {type => SCALAR,
457 locks => {type => HASHREF,
463 my @data = read_bug(bug => $param{bug},
465 exists $param{location} ? (location => $param{location}):(),
466 exists $param{locks} ? (locks => $param{locks}):(),
468 if (not @data or not defined $data[0]) {
472 if (not length $data[0]->{mergedwith}) {
473 return ($locks,@data);
475 unfilelock(exists $param{locks}?$param{locks}:());
477 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
479 @data = read_bug(bug => $param{bug},
481 exists $param{location} ? (location => $param{location}):(),
482 exists $param{locks} ? (locks => $param{locks}):(),
484 if (not @data or not defined $data[0]) {
485 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
490 my @bugs = split / /, $data[0]->{mergedwith};
491 push @bugs, $param{bug};
492 for my $bug (@bugs) {
494 if ($bug != $param{bug}) {
496 read_bug(bug => $bug,
498 exists $param{location} ? (location => $param{location}):(),
499 exists $param{locks} ? (locks => $param{locks}):(),
501 if (not defined $newdata) {
503 unfilelock(exists $param{locks}?$param{locks}:());
506 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
511 # perform a sanity check to make sure that the merged bugs
512 # are all merged with eachother
513 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } @bugs);
514 if ($newdata->{mergedwith} ne $expectmerge) {
516 unfilelock(exists $param{locks}?$param{locks}:());
518 die "Bug $param{bug} differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
522 return ($locks,@data);
527 my $new_bug_num = new_bug(copy => $data->{bug_num});
529 Creates a new bug and returns the new bug number upon success.
537 validate_with(params => \@_,
538 spec => {copy => {type => SCALAR,
544 filelock("nextnumber.lock");
545 my $nn_fh = IO::File->new("nextnumber",'r') or
546 die "Unable to open nextnuber for reading: $!";
549 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
551 overwritefile("nextnumber",
554 my $nn_hash = get_hashname($nn);
556 my $c_hash = get_hashname($param{copy});
557 for my $file (qw(log status summary report)) {
558 copy("db-h/$c_hash/$param{copy}.$file",
559 "db-h/$nn_hash/${nn}.$file")
563 for my $file (qw(log status summary report)) {
564 overwritefile("db-h/$nn_hash/${nn}.$file",
569 # this probably needs to be munged to do something more elegant
570 # &bughook('new', $clone, $data);
577 my @v1fieldorder = qw(originator date subject msgid package
578 keywords done forwarded mergedwith severity);
582 my $content = makestatus($status,$version)
583 my $content = makestatus($status);
585 Creates the content for a status file based on the $status hashref
588 Really only useful for writebug
590 Currently defaults to version 2 (non-encoded rfc1522 names) but will
591 eventually default to version 3. If you care, you should specify a
597 my ($data,$version) = @_;
598 $version = 3 unless defined $version;
602 my %newdata = %$data;
603 for my $field (qw(found fixed)) {
604 if (exists $newdata{$field}) {
605 $newdata{"${field}_date"} =
606 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
609 %newdata = %{join_status_fields(\%newdata)};
611 %newdata = encode_utf8_structure(%newdata);
614 for my $field (@rfc1522_fields) {
615 $newdata{$field} = encode_rfc1522($newdata{$field});
619 # this is a bit of a hack; we should never, ever have \r or \n in
620 # the fields of status. Kill them off here. [Eventually, this
621 # should be superfluous.]
622 for my $field (keys %newdata) {
623 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
627 for my $field (@v1fieldorder) {
628 if (exists $newdata{$field} and defined $newdata{$field}) {
629 $contents .= "$newdata{$field}\n";
634 } elsif ($version == 2 or $version == 3) {
635 # Version 2 or 3. Add a file format version number for the sake of
636 # further extensibility in the future.
637 $contents .= "Format-Version: $version\n";
638 for my $field (keys %fields) {
639 if (exists $newdata{$field} and defined $newdata{$field}
640 and $newdata{$field} ne '') {
641 # Output field names in proper case, e.g. 'Merged-With'.
642 my $properfield = $fields{$field};
643 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
644 my $data = $newdata{$field};
645 $contents .= "$properfield: $data\n";
654 writebug($bug_num,$status,$location,$minversion,$disablebughook)
656 Writes the bug status and summary files out.
658 Skips writting out a status file if minversion is 2
660 Does not call bughook if disablebughook is true.
665 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
668 my %outputs = (1 => 'status', 3 => 'summary');
669 for my $version (keys %outputs) {
670 next if defined $minversion and $version < $minversion;
671 my $status = getbugcomponent($ref, $outputs{$version}, $location);
672 die "can't find location for $ref" unless defined $status;
675 open $sfh,">","$status.new" or
676 die "opening $status.new: $!";
679 open $sfh,">","$status.new" or
680 die "opening $status.new: $!";
682 print {$sfh} makestatus($data, $version) or
683 die "writing $status.new: $!";
684 close($sfh) or die "closing $status.new: $!";
690 rename("$status.new",$status) || die "installing new $status: $!";
693 # $disablebughook is a bit of a hack to let format migration scripts use
694 # this function rather than having to duplicate it themselves.
695 &bughook($change,$ref,$data) unless $disablebughook;
698 =head2 unlockwritebug
700 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
702 Writes a bug, then calls unfilelock; see writebug for what these
714 The following functions are exported with the :versions tag
716 =head2 addfoundversions
718 addfoundversions($status,$package,$version,$isbinary);
720 All use of this should be phased out in favor of Debbugs::Control::fixed/found
725 sub addfoundversions {
729 my $isbinary = shift;
730 return unless defined $version;
731 undef $package if $package =~ m[(?:\s|/)];
732 my $source = $package;
733 if ($package =~ s/^src://) {
738 if (defined $package and $isbinary) {
739 my @srcinfo = binary_to_source(binary => $package,
740 version => $version);
742 # We know the source package(s). Use a fully-qualified version.
743 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
746 # Otherwise, an unqualified version will have to do.
750 # Strip off various kinds of brain-damage.
752 $version =~ s/ *\(.*\)//;
753 $version =~ s/ +[A-Za-z].*//;
755 foreach my $ver (split /[,\s]+/, $version) {
756 my $sver = defined($source) ? "$source/$ver" : '';
757 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
758 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
760 @{$data->{fixed_versions}} =
761 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
765 =head2 removefoundversions
767 removefoundversions($data,$package,$versiontoremove)
769 Removes found versions from $data
771 If a version is fully qualified (contains /) only versions matching
772 exactly are removed. Otherwise, all versions matching the version
775 Currently $package and $isbinary are entirely ignored, but accepted
776 for backwards compatibilty.
780 sub removefoundversions {
784 my $isbinary = shift;
785 return unless defined $version;
787 foreach my $ver (split /[,\s]+/, $version) {
789 # fully qualified version
790 @{$data->{found_versions}} =
792 @{$data->{found_versions}};
795 # non qualified version; delete all matchers
796 @{$data->{found_versions}} =
797 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
798 @{$data->{found_versions}};
804 sub addfixedversions {
808 my $isbinary = shift;
809 return unless defined $version;
810 undef $package if defined $package and $package =~ m[(?:\s|/)];
811 my $source = $package;
813 if (defined $package and $isbinary) {
814 my @srcinfo = binary_to_source(binary => $package,
815 version => $version);
817 # We know the source package(s). Use a fully-qualified version.
818 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
821 # Otherwise, an unqualified version will have to do.
825 # Strip off various kinds of brain-damage.
827 $version =~ s/ *\(.*\)//;
828 $version =~ s/ +[A-Za-z].*//;
830 foreach my $ver (split /[,\s]+/, $version) {
831 my $sver = defined($source) ? "$source/$ver" : '';
832 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
833 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
835 @{$data->{found_versions}} =
836 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
840 sub removefixedversions {
844 my $isbinary = shift;
845 return unless defined $version;
847 foreach my $ver (split /[,\s]+/, $version) {
849 # fully qualified version
850 @{$data->{fixed_versions}} =
852 @{$data->{fixed_versions}};
855 # non qualified version; delete all matchers
856 @{$data->{fixed_versions}} =
857 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
858 @{$data->{fixed_versions}};
869 Split a package string from the status file into a list of package names.
875 return unless defined $pkgs;
876 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
880 =head2 bug_archiveable
882 bug_archiveable(bug => $bug_num);
888 =item bug -- bug number (required)
890 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
892 =item version -- Debbugs::Version information (optional)
894 =item days_until -- return days until the bug can be archived
898 Returns 1 if the bug can be archived
899 Returns 0 if the bug cannot be archived
901 If days_until is true, returns the number of days until the bug can be
902 archived, -1 if it cannot be archived. 0 means that the bug can be
903 archived the next time the archiver runs.
905 Returns undef on failure.
909 # This will eventually need to be fixed before we start using mod_perl
910 our $version_cache = {};
912 my %param = validate_with(params => \@_,
913 spec => {bug => {type => SCALAR,
916 status => {type => HASHREF,
919 days_until => {type => BOOLEAN,
922 ignore_time => {type => BOOLEAN,
927 # This is what we return if the bug cannot be archived.
928 my $cannot_archive = $param{days_until}?-1:0;
929 # read the status information
930 my $status = $param{status};
931 if (not exists $param{status} or not defined $status) {
932 $status = read_bug(bug=>$param{bug});
933 if (not defined $status) {
934 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
938 # Bugs can be archived if they are
940 if (not defined $status->{done} or not length $status->{done}) {
941 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
942 return $cannot_archive
944 # Check to make sure that the bug has none of the unremovable tags set
945 if (@{$config{removal_unremovable_tags}}) {
946 for my $tag (split ' ', ($status->{keywords}||'')) {
947 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
948 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
949 return $cannot_archive;
954 # If we just are checking if the bug can be archived, we'll not even bother
955 # checking the versioning information if the bug has been -done for less than 28 days.
956 my $log_file = getbugcomponent($param{bug},'log');
957 if (not defined $log_file) {
958 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
959 return $cannot_archive;
961 my $max_log_age = max(map {$config{remove_age} - -M $_}
962 $log_file, map {my $log = getbugcomponent($_,'log');
963 defined $log ? ($log) : ();
965 split / /, $status->{mergedwith}
967 if (not $param{days_until} and not $param{ignore_time}
970 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
971 return $cannot_archive;
973 # At this point, we have to get the versioning information for this bug.
974 # We examine the set of distribution tags. If a bug has no distribution
975 # tags set, we assume a default set, otherwise we use the tags the bug
978 # In cases where we are assuming a default set, if the severity
979 # is strong, we use the strong severity default; otherwise, we
980 # use the normal default.
982 # There must be fixed_versions for us to look at the versioning
984 my $min_fixed_time = time;
985 my $min_archive_days = 0;
986 if (@{$status->{fixed_versions}}) {
988 @dist_tags{@{$config{removal_distribution_tags}}} =
989 (1) x @{$config{removal_distribution_tags}};
991 for my $tag (split ' ', ($status->{keywords}||'')) {
992 next unless exists $config{distribution_aliases}{$tag};
993 next unless $dist_tags{$config{distribution_aliases}{$tag}};
994 $dists{$config{distribution_aliases}{$tag}} = 1;
996 if (not keys %dists) {
997 if (isstrongseverity($status->{severity})) {
998 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
999 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1002 @dists{@{$config{removal_default_distribution_tags}}} =
1003 (1) x @{$config{removal_default_distribution_tags}};
1006 my %source_versions;
1007 my @sourceversions = get_versions(package => $status->{package},
1008 dist => [keys %dists],
1011 @source_versions{@sourceversions} = (1) x @sourceversions;
1012 # If the bug has not been fixed in the versions actually
1013 # distributed, then it cannot be archived.
1014 if ('found' eq max_buggy(bug => $param{bug},
1015 sourceversions => [keys %source_versions],
1016 found => $status->{found_versions},
1017 fixed => $status->{fixed_versions},
1018 version_cache => $version_cache,
1019 package => $status->{package},
1021 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1022 return $cannot_archive;
1024 # Since the bug has at least been fixed in the architectures
1025 # that matters, we check to see how long it has been fixed.
1027 # If $param{ignore_time}, then we should ignore time.
1028 if ($param{ignore_time}) {
1029 return $param{days_until}?0:1;
1032 # To do this, we order the times from most recent to oldest;
1033 # when we come to the first found version, we stop.
1034 # If we run out of versions, we only report the time of the
1036 my %time_versions = get_versions(package => $status->{package},
1037 dist => [keys %dists],
1041 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1042 my $buggy = buggy(bug => $param{bug},
1043 version => $version,
1044 found => $status->{found_versions},
1045 fixed => $status->{fixed_versions},
1046 version_cache => $version_cache,
1047 package => $status->{package},
1049 last if $buggy eq 'found';
1050 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1052 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1053 # if there are no versions in the archive at all, then
1054 # we can archive if enough days have passed
1057 # If $param{ignore_time}, then we should ignore time.
1058 if ($param{ignore_time}) {
1059 return $param{days_until}?0:1;
1061 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1062 my $age = ceil($max_log_age);
1063 if ($age > 0 or $min_archive_days > 0) {
1064 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1065 return $param{days_until}?max($age,$min_archive_days):0;
1068 return $param{days_until}?0:1;
1073 =head2 get_bug_status
1075 my $status = get_bug_status(bug => $nnn);
1077 my $status = get_bug_status($bug_num)
1083 =item bug -- scalar bug number
1085 =item status -- optional hashref of bug status as returned by readbug
1086 (can be passed to avoid rereading the bug information)
1088 =item bug_index -- optional tied index of bug status infomration;
1089 currently not correctly implemented.
1091 =item version -- optional version(s) to check package status at
1093 =item dist -- optional distribution(s) to check package status at
1095 =item arch -- optional architecture(s) to check package status at
1097 =item bugusertags -- optional hashref of bugusertags
1099 =item sourceversion -- optional arrayref of source/version; overrides
1100 dist, arch, and version. [The entries in this array must be in the
1101 "source/version" format.] Eventually this can be used to for caching.
1103 =item indicatesource -- if true, indicate which source packages this
1104 bug could belong to (or does belong to in the case of bugs assigned to
1105 a source package). Defaults to true.
1109 Note: Currently the version information is cached; this needs to be
1110 changed before using this function in long lived programs.
1114 Currently returns a hashref of status with the following keys.
1118 =item id -- bug number
1120 =item bug_num -- duplicate of id
1122 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1124 =item tags -- duplicate of keywords
1126 =item package -- name of package that the bug is assigned to
1128 =item severity -- severity of the bug
1130 =item pending -- pending state of the bug; one of following possible
1131 values; values listed later have precedence if multiple conditions are
1136 =item pending -- default state
1138 =item forwarded -- bug has been forwarded
1140 =item pending-fixed -- bug is tagged pending
1142 =item fixed -- bug is tagged fixed
1144 =item absent -- bug does not apply to this distribution/architecture
1146 =item done -- bug is resolved in this distribution/architecture
1150 =item location -- db-h or archive; the location in the filesystem
1152 =item subject -- title of the bug
1154 =item last_modified -- epoch that the bug was last modified
1156 =item date -- epoch that the bug was filed
1158 =item originator -- bug reporter
1160 =item log_modified -- epoch that the log file was last modified
1162 =item msgid -- Message id of the original bug report
1167 Other key/value pairs are returned but are not currently documented here.
1171 sub get_bug_status {
1175 my %param = validate_with(params => \@_,
1176 spec => {bug => {type => SCALAR,
1179 status => {type => HASHREF,
1182 bug_index => {type => OBJECT,
1185 version => {type => SCALAR|ARRAYREF,
1188 dist => {type => SCALAR|ARRAYREF,
1191 arch => {type => SCALAR|ARRAYREF,
1194 bugusertags => {type => HASHREF,
1197 sourceversions => {type => ARRAYREF,
1200 indicatesource => {type => BOOLEAN,
1207 if (defined $param{bug_index} and
1208 exists $param{bug_index}{$param{bug}}) {
1209 %status = %{ $param{bug_index}{$param{bug}} };
1210 $status{pending} = $status{ status };
1211 $status{id} = $param{bug};
1214 if (defined $param{status}) {
1215 %status = %{$param{status}};
1218 my $location = getbuglocation($param{bug}, 'summary');
1219 return {} if not defined $location or not length $location;
1220 %status = %{ readbug( $param{bug}, $location ) };
1222 $status{id} = $param{bug};
1224 if (defined $param{bugusertags}{$param{bug}}) {
1225 $status{keywords} = "" unless defined $status{keywords};
1226 $status{keywords} .= " " unless $status{keywords} eq "";
1227 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1229 $status{tags} = $status{keywords};
1230 my %tags = map { $_ => 1 } split ' ', $status{tags};
1232 $status{package} = '' if not defined $status{package};
1233 $status{"package"} =~ s/\s*$//;
1235 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1239 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1240 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1242 $status{"pending"} = 'pending';
1243 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1244 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1245 $status{"pending"} = 'fixed' if ($tags{fixed});
1248 my $presence = bug_presence(status => \%status,
1249 map{(exists $param{$_})?($_,$param{$_}):()}
1250 qw(bug sourceversions arch dist version found fixed package)
1252 if (defined $presence) {
1253 if ($presence eq 'fixed') {
1254 $status{pending} = 'done';
1256 elsif ($presence eq 'absent') {
1257 $status{pending} = 'absent';
1265 my $precence = bug_presence(bug => nnn,
1269 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1270 is found, absent, fixed, or no information is available in the
1271 distribution (dist) and/or architecture (arch) specified.
1278 =item bug -- scalar bug number
1280 =item status -- optional hashref of bug status as returned by readbug
1281 (can be passed to avoid rereading the bug information)
1283 =item bug_index -- optional tied index of bug status infomration;
1284 currently not correctly implemented.
1286 =item version -- optional version to check package status at
1288 =item dist -- optional distribution to check package status at
1290 =item arch -- optional architecture to check package status at
1292 =item sourceversion -- optional arrayref of source/version; overrides
1293 dist, arch, and version. [The entries in this array must be in the
1294 "source/version" format.] Eventually this can be used to for caching.
1301 my %param = validate_with(params => \@_,
1302 spec => {bug => {type => SCALAR,
1305 status => {type => HASHREF,
1308 version => {type => SCALAR|ARRAYREF,
1311 dist => {type => SCALAR|ARRAYREF,
1314 arch => {type => SCALAR|ARRAYREF,
1317 sourceversions => {type => ARRAYREF,
1323 if (defined $param{status}) {
1324 %status = %{$param{status}};
1327 my $location = getbuglocation($param{bug}, 'summary');
1328 return {} if not length $location;
1329 %status = %{ readbug( $param{bug}, $location ) };
1333 my $pseudo_desc = getpseudodesc();
1334 if (not exists $param{sourceversions}) {
1336 # pseudopackages do not have source versions by definition.
1337 if (exists $pseudo_desc->{$status{package}}) {
1340 elsif (defined $param{version}) {
1341 foreach my $arch (make_list($param{arch})) {
1342 for my $package (split /\s*,\s*/, $status{package}) {
1343 my @temp = makesourceversions($package,
1345 make_list($param{version})
1347 @sourceversions{@temp} = (1) x @temp;
1350 } elsif (defined $param{dist}) {
1351 my %affects_distribution_tags;
1352 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1353 (1) x @{$config{affects_distribution_tags}};
1354 my $some_distributions_disallowed = 0;
1355 my %allowed_distributions;
1356 for my $tag (split ' ', ($status{keywords}||'')) {
1357 if (exists $config{distribution_aliases}{$tag} and
1358 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1359 $some_distributions_disallowed = 1;
1360 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1362 elsif (exists $affects_distribution_tags{$tag}) {
1363 $some_distributions_disallowed = 1;
1364 $allowed_distributions{$tag} = 1;
1367 my @archs = make_list(exists $param{arch}?$param{arch}:());
1368 GET_SOURCE_VERSIONS:
1369 foreach my $arch (@archs) {
1370 for my $package (split /\s*,\s*/, $status{package}) {
1373 if ($package =~ /^src:(.+)$/) {
1377 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1378 # if some distributions are disallowed,
1379 # and this isn't an allowed
1380 # distribution, then we ignore this
1381 # distribution for the purposees of
1383 if ($some_distributions_disallowed and
1384 not exists $allowed_distributions{$dist}) {
1387 push @versions, get_versions(package => $package,
1389 ($source?(arch => 'source'):
1390 (defined $arch?(arch => $arch):())),
1393 next unless @versions;
1394 my @temp = make_source_versions(package => $package,
1396 versions => \@versions,
1398 @sourceversions{@temp} = (1) x @temp;
1401 # this should really be split out into a subroutine,
1402 # but it'd touch so many things currently, that we fake
1403 # it; it's needed to properly handle bugs which are
1404 # erroneously assigned to the binary package, and we'll
1405 # probably have it go away eventually.
1406 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1408 goto GET_SOURCE_VERSIONS;
1412 # TODO: This should probably be handled further out for efficiency and
1413 # for more ease of distinguishing between pkg= and src= queries.
1414 # DLA: src= queries should just pass arch=source, and they'll be happy.
1415 @sourceversions = keys %sourceversions;
1418 @sourceversions = @{$param{sourceversions}};
1420 my $maxbuggy = 'undef';
1421 if (@sourceversions) {
1422 $maxbuggy = max_buggy(bug => $param{bug},
1423 sourceversions => \@sourceversions,
1424 found => $status{found_versions},
1425 fixed => $status{fixed_versions},
1426 package => $status{package},
1427 version_cache => $version_cache,
1430 elsif (defined $param{dist} and
1431 not exists $pseudo_desc->{$status{package}}) {
1434 if (length($status{done}) and
1435 (not @sourceversions or not @{$status{fixed_versions}})) {
1450 =item bug -- scalar bug number
1452 =item sourceversion -- optional arrayref of source/version; overrides
1453 dist, arch, and version. [The entries in this array must be in the
1454 "source/version" format.] Eventually this can be used to for caching.
1458 Note: Currently the version information is cached; this needs to be
1459 changed before using this function in long lived programs.
1464 my %param = validate_with(params => \@_,
1465 spec => {bug => {type => SCALAR,
1468 sourceversions => {type => ARRAYREF,
1471 found => {type => ARRAYREF,
1474 fixed => {type => ARRAYREF,
1477 package => {type => SCALAR,
1479 version_cache => {type => HASHREF,
1484 # Resolve bugginess states (we might be looking at multiple
1485 # architectures, say). Found wins, then fixed, then absent.
1486 my $maxbuggy = 'absent';
1487 for my $package (split /\s*,\s*/, $param{package}) {
1488 for my $version (@{$param{sourceversions}}) {
1489 my $buggy = buggy(bug => $param{bug},
1490 version => $version,
1491 found => $param{found},
1492 fixed => $param{fixed},
1493 version_cache => $param{version_cache},
1494 package => $package,
1496 if ($buggy eq 'found') {
1498 } elsif ($buggy eq 'fixed') {
1499 $maxbuggy = 'fixed';
1516 Returns the output of Debbugs::Versions::buggy for a particular
1517 package, version and found/fixed set. Automatically turns found, fixed
1518 and version into source/version strings.
1520 Caching can be had by using the version_cache, but no attempt to check
1521 to see if the on disk information is more recent than the cache is
1522 made. [This will need to be fixed for long-lived processes.]
1527 my %param = validate_with(params => \@_,
1528 spec => {bug => {type => SCALAR,
1531 found => {type => ARRAYREF,
1534 fixed => {type => ARRAYREF,
1537 version_cache => {type => HASHREF,
1540 package => {type => SCALAR,
1542 version => {type => SCALAR,
1546 my @found = @{$param{found}};
1547 my @fixed = @{$param{fixed}};
1548 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1549 # We have non-source version versions
1550 @found = makesourceversions($param{package},undef,
1553 @fixed = makesourceversions($param{package},undef,
1557 if ($param{version} !~ m{/}) {
1558 my ($version) = makesourceversions($param{package},undef,
1561 $param{version} = $version if defined $version;
1563 # Figure out which source packages we need
1565 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1566 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1567 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1568 $param{version} =~ m{/};
1570 if (not defined $param{version_cache} or
1571 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1572 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1573 foreach my $source (keys %sources) {
1574 my $srchash = substr $source, 0, 1;
1575 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1576 if (not defined $version_fh) {
1577 # We only want to warn if it's a package which actually has a maintainer
1578 my $maints = getmaintainers();
1579 next if not exists $maints->{$source};
1580 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1583 $version->load($version_fh);
1585 if (defined $param{version_cache}) {
1586 $param{version_cache}{join(',',sort keys %sources)} = $version;
1590 $version = $param{version_cache}{join(',',sort keys %sources)};
1592 return $version->buggy($param{version},\@found,\@fixed);
1595 sub isstrongseverity {
1596 my $severity = shift;
1597 $severity = $config{default_severity} if
1598 not defined $severity or $severity eq '';
1599 return grep { $_ eq $severity } @{$config{strong_severities}};
1603 =head1 PRIVATE FUNCTIONS
1607 sub update_realtime {
1608 my ($file, %bugs) = @_;
1610 # update realtime index.db
1612 return () unless keys %bugs;
1613 my $idx_old = IO::File->new($file,'r')
1614 or die "Couldn't open ${file}: $!";
1615 my $idx_new = IO::File->new($file.'.new','w')
1616 or die "Couldn't open ${file}.new: $!";
1618 my $min_bug = min(keys %bugs);
1622 while($line = <$idx_old>) {
1623 @line = split /\s/, $line;
1624 # Two cases; replacing existing line or adding new line
1625 if (exists $bugs{$line[1]}) {
1626 my $new = $bugs{$line[1]};
1627 delete $bugs{$line[1]};
1628 $min_bug = min(keys %bugs);
1629 if ($new eq "NOCHANGE") {
1630 print {$idx_new} $line;
1631 $changed_bugs{$line[1]} = $line;
1632 } elsif ($new eq "REMOVE") {
1633 $changed_bugs{$line[1]} = $line;
1635 print {$idx_new} $new;
1636 $changed_bugs{$line[1]} = $line;
1640 while ($line[1] > $min_bug) {
1641 print {$idx_new} $bugs{$min_bug};
1642 delete $bugs{$min_bug};
1643 last unless keys %bugs;
1644 $min_bug = min(keys %bugs);
1646 print {$idx_new} $line;
1648 last unless keys %bugs;
1650 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1652 print {$idx_new} <$idx_old>;
1657 rename("$file.new", $file);
1659 return %changed_bugs;
1662 sub bughook_archive {
1664 filelock("$config{spool_dir}/debbugs.trace.lock");
1665 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1666 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1667 map{($_,'REMOVE')} @refs);
1668 update_realtime("$config{spool_dir}/index.archive.realtime",
1674 my ( $type, %bugs_temp ) = @_;
1675 filelock("$config{spool_dir}/debbugs.trace.lock");
1678 for my $bug (keys %bugs_temp) {
1679 my $data = $bugs_temp{$bug};
1680 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1682 my $whendone = "open";
1683 my $severity = $config{default_severity};
1684 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1685 $pkglist =~ s/^,+//;
1686 $pkglist =~ s/,+$//;
1687 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1688 $whendone = "done" if defined $data->{done} and length $data->{done};
1689 $severity = $data->{severity} if length $data->{severity};
1691 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1692 $pkglist, $bug, $data->{date}, $whendone,
1693 $data->{originator}, $severity, $data->{keywords};
1696 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);