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);
49 use Storable qw(dclone);
50 use List::Util qw(min max);
56 $DEBUG = 0 unless defined $DEBUG;
59 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
60 qw(isstrongseverity bug_presence split_status_fields),
62 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
63 qw(lock_read_all_merged_bugs),
65 write => [qw(writebug makestatus unlockwritebug)],
67 versions => [qw(addfoundversions addfixedversions),
68 qw(removefoundversions removefixedversions)
70 hook => [qw(bughook bughook_archive)],
71 fields => [qw(%fields)],
74 Exporter::export_ok_tags(keys %EXPORT_TAGS);
75 $EXPORT_TAGS{all} = [@EXPORT_OK];
81 readbug($bug_num,$location)
84 Reads a summary file from the archive given a bug number and a bug
85 location. Valid locations are those understood by L</getbugcomponent>
89 # these probably shouldn't be imported by most people, but
90 # Debbugs::Control needs them, so they're now exportable
91 our %fields = (originator => 'submitter',
94 msgid => 'message-id',
95 'package' => 'package',
98 forwarded => 'forwarded-to',
99 mergedwith => 'merged-with',
100 severity => 'severity',
102 found_versions => 'found-in',
103 found_date => 'found-date',
104 fixed_versions => 'fixed-in',
105 fixed_date => 'fixed-date',
107 blockedby => 'blocked-by',
108 unarchived => 'unarchived',
109 summary => 'summary',
110 affects => 'affects',
114 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
115 my @rfc1522_fields = qw(originator subject done forwarded owner);
118 return read_bug(bug => $_[0],
119 (@_ > 1)?(location => $_[1]):()
125 read_bug(bug => $bug_num,
126 location => 'archive',
128 read_bug(summary => 'path/to/bugnum.summary');
131 A more complete function than readbug; it enables you to pass a full
132 path to the summary file instead of the bug number and/or location.
138 =item bug -- the bug number
140 =item location -- optional location which is passed to getbugcomponent
142 =item summary -- complete path to the .summary file which will be read
144 =item lock -- whether to obtain a lock for the bug to prevent
145 something modifying it while the bug has been read. You B<must> call
146 C<unfilelock();> if something not undef is returned from read_bug.
148 =item locks -- hashref of already obtained locks; incremented as new
149 locks are needed, and decremented as locks are released on particular
154 One of C<bug> or C<summary> must be passed. This function will return
155 undef on failure, and will die if improper arguments are passed.
163 my %param = validate_with(params => \@_,
164 spec => {bug => {type => SCALAR,
168 # negative bugnumbers
171 location => {type => SCALAR|UNDEF,
174 summary => {type => SCALAR,
177 lock => {type => BOOLEAN,
180 locks => {type => HASHREF,
185 die "One of bug or summary must be passed to read_bug"
186 if not exists $param{bug} and not exists $param{summary};
190 if (not defined $param{summary}) {
192 ($lref,$location) = @param{qw(bug location)};
193 if (not defined $location) {
194 $location = getbuglocation($lref,'summary');
195 return undef if not defined $location;
197 $status = getbugcomponent($lref, 'summary', $location);
198 $log = getbugcomponent($lref, 'log' , $location);
199 return undef unless defined $status;
200 return undef if not -e $status;
203 $status = $param{summary};
205 $log =~ s/\.summary$/.log/;
206 ($location) = $status =~ m/(db-h|db|archive)/;
209 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
211 my $status_fh = IO::File->new($status, 'r');
212 if (not defined $status_fh) {
213 warn "Unable to open $status for reading: $!";
215 unfilelock(exists $param{locks}?$param{locks}:());
225 while (<$status_fh>) {
228 $version = $1 if /^Format-Version: ([0-9]+)/i;
231 # Version 3 is the latest format version currently supported.
233 warn "Unsupported status version '$version'";
235 unfilelock(exists $param{locks}?$param{locks}:());
240 my %namemap = reverse %fields;
241 for my $line (@lines) {
242 if ($line =~ /(\S+?): (.*)/) {
243 my ($name, $value) = (lc $1, $2);
244 # this is a bit of a hack; we should never, ever have \r
245 # or \n in the fields of status. Kill them off here.
246 # [Eventually, this should be superfluous.]
247 $value =~ s/[\r\n]//g;
248 $data{$namemap{$name}} = $value if exists $namemap{$name};
251 for my $field (keys %fields) {
252 $data{$field} = '' unless exists $data{$field};
255 $data{severity} = $config{default_severity} if $data{severity} eq '';
256 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
257 $data{$field} = [split ' ', $data{$field}];
259 for my $field (qw(found fixed)) {
260 # create the found/fixed hashes which indicate when a
261 # particular version was marked found or marked fixed.
262 @{$data{$field}}{@{$data{"${field}_versions"}}} =
263 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
264 @{$data{"${field}_date"}});
268 for my $field (@rfc1522_fields) {
269 $data{$field} = decode_rfc1522($data{$field});
272 my $status_modified = (stat($status))[9];
273 # Add log last modified time
274 $data{log_modified} = (stat($log))[9];
275 $data{last_modified} = max($status_modified,$data{log_modified});
276 $data{location} = $location;
277 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
278 $data{bug_num} = $param{bug};
283 =head2 split_status_fields
285 my @data = split_status_fields(@data);
287 Splits splittable status fields (like package, tags, blocks,
288 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
289 passed @data intact using dclone.
291 In scalar context, returns only the first element of @data.
295 our $ditch_empty = sub{
297 my $splitter = shift @t;
298 return grep {length $_} map {split $splitter} @t;
301 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
303 (package => \&splitpackages,
304 affects => \&splitpackages,
305 blocks => $ditch_empty_space,
306 blockedby => $ditch_empty_space,
307 # this isn't strictly correct, but we'll split both of them for
308 # the time being until we ditch all use of keywords everywhere
310 keywords => $ditch_empty_space,
311 tags => $ditch_empty_space,
312 found_versions => $ditch_empty_space,
313 fixed_versions => $ditch_empty_space,
314 mergedwith => $ditch_empty_space,
317 sub split_status_fields {
318 my @data = @{dclone(\@_)};
319 for my $data (@data) {
320 next if not defined $data;
321 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
322 not (ref($data) and ref($data) eq 'HASH');
323 for my $field (keys %{$data}) {
324 next unless defined $data->{$field};
325 if (exists $split_fields{$field}) {
326 next if ref($data->{$field});
328 if (ref($split_fields{$field}) eq 'CODE') {
329 @elements = &{$split_fields{$field}}($data->{$field});
331 elsif (not ref($split_fields{$field}) or
332 UNIVERSAL::isa($split_fields{$field},'Regex')
334 @elements = split $split_fields{$field}, $data->{$field};
336 $data->{$field} = \@elements;
340 return wantarray?@data:$data[0];
343 =head2 join_status_fields
345 my @data = join_status_fields(@data);
347 Handles joining the splitable status fields. (Basically, the inverse
348 of split_status_fields.
350 Primarily called from makestatus, but may be useful for other
351 functions after calling split_status_fields (or for legacy functions
352 if we transition to split fields by default).
356 sub join_status_fields {
363 found_versions => ' ',
364 fixed_versions => ' ',
369 my @data = @{dclone(\@_)};
370 for my $data (@data) {
371 next if not defined $data;
372 croak "Passed an element which is not a hashref to split_status_field: ".
374 if ref($data) ne 'HASH';
375 for my $field (keys %{$data}) {
376 next unless defined $data->{$field};
377 next unless ref($data->{$field}) eq 'ARRAY';
378 next unless exists $join_fields{$field};
379 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
382 return wantarray?@data:$data[0];
388 lockreadbug($bug_num,$location)
390 Performs a filelock, then reads the bug; the bug is unlocked if the
391 return is undefined, otherwise, you need to call unfilelock or
394 See readbug above for information on what this returns
399 my ($lref, $location) = @_;
400 return read_bug(bug => $lref, location => $location, lock => 1);
403 =head2 lockreadbugmerge
405 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
407 Performs a filelock, then reads the bug. If the bug is merged, locks
408 the merge lock. Returns a list of the number of locks and the bug
413 sub lockreadbugmerge {
414 my ($bug_num,$location) = @_;
415 my $data = lockreadbug(@_);
416 if (not defined $data) {
419 if (not length $data->{mergedwith}) {
423 filelock("$config{spool_dir}/lock/merge");
424 $data = lockreadbug(@_);
425 if (not defined $data) {
432 =head2 lock_read_all_merged_bugs
434 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
436 Performs a filelock, then reads the bug passed. If the bug is merged,
437 locks the merge lock, then reads and locks all of the other merged
438 bugs. Returns a list of the number of locks and the bug data for all
441 Will also return undef if any of the merged bugs failed to be read,
442 even if all of the others were read properly.
446 sub lock_read_all_merged_bugs {
447 my %param = validate_with(params => \@_,
448 spec => {bug => {type => SCALAR,
451 location => {type => SCALAR,
454 locks => {type => HASHREF,
460 my @data = read_bug(bug => $param{bug},
462 exists $param{location} ? (location => $param{location}):(),
463 exists $param{locks} ? (locks => $param{locks}):(),
465 if (not @data or not defined $data[0]) {
469 if (not length $data[0]->{mergedwith}) {
470 return ($locks,@data);
472 unfilelock(exists $param{locks}?$param{locks}:());
474 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
476 @data = read_bug(bug => $param{bug},
478 exists $param{location} ? (location => $param{location}):(),
479 exists $param{locks} ? (locks => $param{locks}):(),
481 if (not @data or not defined $data[0]) {
482 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
487 my @bugs = split / /, $data[0]->{mergedwith};
488 push @bugs, $param{bug};
489 for my $bug (@bugs) {
491 if ($bug != $param{bug}) {
493 read_bug(bug => $bug,
495 exists $param{location} ? (location => $param{location}):(),
496 exists $param{locks} ? (locks => $param{locks}):(),
498 if (not defined $newdata) {
500 unfilelock(exists $param{locks}?$param{locks}:());
503 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
508 # perform a sanity check to make sure that the merged bugs
509 # are all merged with eachother
510 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } @bugs);
511 if ($newdata->{mergedwith} ne $expectmerge) {
513 unfilelock(exists $param{locks}?$param{locks}:());
515 die "Bug $param{bug} differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
519 return ($locks,@data);
524 my $new_bug_num = new_bug(copy => $data->{bug_num});
526 Creates a new bug and returns the new bug number upon success.
534 validate_with(params => \@_,
535 spec => {copy => {type => SCALAR,
541 filelock("nextnumber.lock");
542 my $nn_fh = IO::File->new("nextnumber",'r') or
543 die "Unable to open nextnuber for reading: $!";
546 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
548 overwritefile("nextnumber",
551 my $nn_hash = get_hashname($nn);
553 my $t_fh = IO::File->new("/home/don/temp.txt",'a') or die "Unable to open ~don/temp.txt for writing: $!";
555 print {$t_fh} Dumper({%param,nn => $nn, nn_hash => $nn_hash, nextnumber => qx(cat nextnumber)});
558 my $c_hash = get_hashname($param{copy});
559 for my $file (qw(log status summary report)) {
560 copy("db-h/$c_hash/$param{copy}.$file",
561 "db-h/$nn_hash/${nn}.$file")
565 for my $file (qw(log status summary report)) {
566 overwritefile("db-h/$nn_hash/${nn}.$file",
571 # this probably needs to be munged to do something more elegant
572 # &bughook('new', $clone, $data);
579 my @v1fieldorder = qw(originator date subject msgid package
580 keywords done forwarded mergedwith severity);
584 my $content = makestatus($status,$version)
585 my $content = makestatus($status);
587 Creates the content for a status file based on the $status hashref
590 Really only useful for writebug
592 Currently defaults to version 2 (non-encoded rfc1522 names) but will
593 eventually default to version 3. If you care, you should specify a
599 my ($data,$version) = @_;
600 $version = 2 unless defined $version;
604 my %newdata = %$data;
605 for my $field (qw(found fixed)) {
606 if (exists $newdata{$field}) {
607 $newdata{"${field}_date"} =
608 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
611 %newdata = %{join_status_fields(\%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 $contents .= "$properfield: $newdata{$field}\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', 2 => '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;
673 open(S,"> $status.new") || die "opening $status.new: $!";
674 print(S makestatus($data, $version)) ||
675 die "writing $status.new: $!";
676 close(S) || die "closing $status.new: $!";
682 rename("$status.new",$status) || die "installing new $status: $!";
685 # $disablebughook is a bit of a hack to let format migration scripts use
686 # this function rather than having to duplicate it themselves.
687 &bughook($change,$ref,$data) unless $disablebughook;
690 =head2 unlockwritebug
692 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
694 Writes a bug, then calls unfilelock; see writebug for what these
706 The following functions are exported with the :versions tag
708 =head2 addfoundversions
710 addfoundversions($status,$package,$version,$isbinary);
712 All use of this should be phased out in favor of Debbugs::Control::fixed/found
717 sub addfoundversions {
721 my $isbinary = shift;
722 return unless defined $version;
723 undef $package if $package =~ m[(?:\s|/)];
724 my $source = $package;
725 if ($package =~ s/^src://) {
730 if (defined $package and $isbinary) {
731 my @srcinfo = binary_to_source(binary => $package,
732 version => $version);
734 # We know the source package(s). Use a fully-qualified version.
735 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
738 # Otherwise, an unqualified version will have to do.
742 # Strip off various kinds of brain-damage.
744 $version =~ s/ *\(.*\)//;
745 $version =~ s/ +[A-Za-z].*//;
747 foreach my $ver (split /[,\s]+/, $version) {
748 my $sver = defined($source) ? "$source/$ver" : '';
749 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
750 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
752 @{$data->{fixed_versions}} =
753 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
757 =head2 removefoundversions
759 removefoundversions($data,$package,$versiontoremove)
761 Removes found versions from $data
763 If a version is fully qualified (contains /) only versions matching
764 exactly are removed. Otherwise, all versions matching the version
767 Currently $package and $isbinary are entirely ignored, but accepted
768 for backwards compatibilty.
772 sub removefoundversions {
776 my $isbinary = shift;
777 return unless defined $version;
779 foreach my $ver (split /[,\s]+/, $version) {
781 # fully qualified version
782 @{$data->{found_versions}} =
784 @{$data->{found_versions}};
787 # non qualified version; delete all matchers
788 @{$data->{found_versions}} =
789 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
790 @{$data->{found_versions}};
796 sub addfixedversions {
800 my $isbinary = shift;
801 return unless defined $version;
802 undef $package if defined $package and $package =~ m[(?:\s|/)];
803 my $source = $package;
805 if (defined $package and $isbinary) {
806 my @srcinfo = binary_to_source(binary => $package,
807 version => $version);
809 # We know the source package(s). Use a fully-qualified version.
810 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
813 # Otherwise, an unqualified version will have to do.
817 # Strip off various kinds of brain-damage.
819 $version =~ s/ *\(.*\)//;
820 $version =~ s/ +[A-Za-z].*//;
822 foreach my $ver (split /[,\s]+/, $version) {
823 my $sver = defined($source) ? "$source/$ver" : '';
824 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
825 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
827 @{$data->{found_versions}} =
828 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
832 sub removefixedversions {
836 my $isbinary = shift;
837 return unless defined $version;
839 foreach my $ver (split /[,\s]+/, $version) {
841 # fully qualified version
842 @{$data->{fixed_versions}} =
844 @{$data->{fixed_versions}};
847 # non qualified version; delete all matchers
848 @{$data->{fixed_versions}} =
849 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
850 @{$data->{fixed_versions}};
861 Split a package string from the status file into a list of package names.
867 return unless defined $pkgs;
868 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
872 =head2 bug_archiveable
874 bug_archiveable(bug => $bug_num);
880 =item bug -- bug number (required)
882 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
884 =item version -- Debbugs::Version information (optional)
886 =item days_until -- return days until the bug can be archived
890 Returns 1 if the bug can be archived
891 Returns 0 if the bug cannot be archived
893 If days_until is true, returns the number of days until the bug can be
894 archived, -1 if it cannot be archived. 0 means that the bug can be
895 archived the next time the archiver runs.
897 Returns undef on failure.
901 # This will eventually need to be fixed before we start using mod_perl
902 our $version_cache = {};
904 my %param = validate_with(params => \@_,
905 spec => {bug => {type => SCALAR,
908 status => {type => HASHREF,
911 days_until => {type => BOOLEAN,
914 ignore_time => {type => BOOLEAN,
919 # This is what we return if the bug cannot be archived.
920 my $cannot_archive = $param{days_until}?-1:0;
921 # read the status information
922 my $status = $param{status};
923 if (not exists $param{status} or not defined $status) {
924 $status = read_bug(bug=>$param{bug});
925 if (not defined $status) {
926 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
930 # Bugs can be archived if they are
932 if (not defined $status->{done} or not length $status->{done}) {
933 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
934 return $cannot_archive
936 # Check to make sure that the bug has none of the unremovable tags set
937 if (@{$config{removal_unremovable_tags}}) {
938 for my $tag (split ' ', ($status->{keywords}||'')) {
939 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
940 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
941 return $cannot_archive;
946 # If we just are checking if the bug can be archived, we'll not even bother
947 # checking the versioning information if the bug has been -done for less than 28 days.
948 my $log_file = getbugcomponent($param{bug},'log');
949 if (not defined $log_file) {
950 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
951 return $cannot_archive;
953 my $max_log_age = max(map {$config{remove_age} - -M $_}
954 $log_file, map {my $log = getbugcomponent($_,'log');
955 defined $log ? ($log) : ();
957 split / /, $status->{mergedwith}
959 if (not $param{days_until} and not $param{ignore_time}
962 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
963 return $cannot_archive;
965 # At this point, we have to get the versioning information for this bug.
966 # We examine the set of distribution tags. If a bug has no distribution
967 # tags set, we assume a default set, otherwise we use the tags the bug
970 # In cases where we are assuming a default set, if the severity
971 # is strong, we use the strong severity default; otherwise, we
972 # use the normal default.
974 # There must be fixed_versions for us to look at the versioning
976 my $min_fixed_time = time;
977 my $min_archive_days = 0;
978 if (@{$status->{fixed_versions}}) {
980 @dist_tags{@{$config{removal_distribution_tags}}} =
981 (1) x @{$config{removal_distribution_tags}};
983 for my $tag (split ' ', ($status->{keywords}||'')) {
984 next unless exists $config{distribution_aliases}{$tag};
985 next unless $dist_tags{$config{distribution_aliases}{$tag}};
986 $dists{$config{distribution_aliases}{$tag}} = 1;
988 if (not keys %dists) {
989 if (isstrongseverity($status->{severity})) {
990 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
991 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
994 @dists{@{$config{removal_default_distribution_tags}}} =
995 (1) x @{$config{removal_default_distribution_tags}};
999 my @sourceversions = get_versions(package => $status->{package},
1000 dist => [keys %dists],
1003 @source_versions{@sourceversions} = (1) x @sourceversions;
1004 # If the bug has not been fixed in the versions actually
1005 # distributed, then it cannot be archived.
1006 if ('found' eq max_buggy(bug => $param{bug},
1007 sourceversions => [keys %source_versions],
1008 found => $status->{found_versions},
1009 fixed => $status->{fixed_versions},
1010 version_cache => $version_cache,
1011 package => $status->{package},
1013 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1014 return $cannot_archive;
1016 # Since the bug has at least been fixed in the architectures
1017 # that matters, we check to see how long it has been fixed.
1019 # If $param{ignore_time}, then we should ignore time.
1020 if ($param{ignore_time}) {
1021 return $param{days_until}?0:1;
1024 # To do this, we order the times from most recent to oldest;
1025 # when we come to the first found version, we stop.
1026 # If we run out of versions, we only report the time of the
1028 my %time_versions = get_versions(package => $status->{package},
1029 dist => [keys %dists],
1033 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1034 my $buggy = buggy(bug => $param{bug},
1035 version => $version,
1036 found => $status->{found_versions},
1037 fixed => $status->{fixed_versions},
1038 version_cache => $version_cache,
1039 package => $status->{package},
1041 last if $buggy eq 'found';
1042 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1044 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1045 # if there are no versions in the archive at all, then
1046 # we can archive if enough days have passed
1049 # If $param{ignore_time}, then we should ignore time.
1050 if ($param{ignore_time}) {
1051 return $param{days_until}?0:1;
1053 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1054 my $age = ceil($max_log_age);
1055 if ($age > 0 or $min_archive_days > 0) {
1056 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1057 return $param{days_until}?max($age,$min_archive_days):0;
1060 return $param{days_until}?0:1;
1065 =head2 get_bug_status
1067 my $status = get_bug_status(bug => $nnn);
1069 my $status = get_bug_status($bug_num)
1075 =item bug -- scalar bug number
1077 =item status -- optional hashref of bug status as returned by readbug
1078 (can be passed to avoid rereading the bug information)
1080 =item bug_index -- optional tied index of bug status infomration;
1081 currently not correctly implemented.
1083 =item version -- optional version(s) to check package status at
1085 =item dist -- optional distribution(s) to check package status at
1087 =item arch -- optional architecture(s) to check package status at
1089 =item bugusertags -- optional hashref of bugusertags
1091 =item sourceversion -- optional arrayref of source/version; overrides
1092 dist, arch, and version. [The entries in this array must be in the
1093 "source/version" format.] Eventually this can be used to for caching.
1095 =item indicatesource -- if true, indicate which source packages this
1096 bug could belong to (or does belong to in the case of bugs assigned to
1097 a source package). Defaults to true.
1101 Note: Currently the version information is cached; this needs to be
1102 changed before using this function in long lived programs.
1106 sub get_bug_status {
1110 my %param = validate_with(params => \@_,
1111 spec => {bug => {type => SCALAR,
1114 status => {type => HASHREF,
1117 bug_index => {type => OBJECT,
1120 version => {type => SCALAR|ARRAYREF,
1123 dist => {type => SCALAR|ARRAYREF,
1126 arch => {type => SCALAR|ARRAYREF,
1129 bugusertags => {type => HASHREF,
1132 sourceversions => {type => ARRAYREF,
1135 indicatesource => {type => BOOLEAN,
1142 if (defined $param{bug_index} and
1143 exists $param{bug_index}{$param{bug}}) {
1144 %status = %{ $param{bug_index}{$param{bug}} };
1145 $status{pending} = $status{ status };
1146 $status{id} = $param{bug};
1149 if (defined $param{status}) {
1150 %status = %{$param{status}};
1153 my $location = getbuglocation($param{bug}, 'summary');
1154 return {} if not defined $location or not length $location;
1155 %status = %{ readbug( $param{bug}, $location ) };
1157 $status{id} = $param{bug};
1159 if (defined $param{bugusertags}{$param{bug}}) {
1160 $status{keywords} = "" unless defined $status{keywords};
1161 $status{keywords} .= " " unless $status{keywords} eq "";
1162 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1164 $status{tags} = $status{keywords};
1165 my %tags = map { $_ => 1 } split ' ', $status{tags};
1167 $status{package} = '' if not defined $status{package};
1168 $status{"package"} =~ s/\s*$//;
1170 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1174 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1175 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1177 $status{"pending"} = 'pending';
1178 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1179 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1180 $status{"pending"} = 'fixed' if ($tags{fixed});
1183 my $presence = bug_presence(status => \%status,
1184 map{(exists $param{$_})?($_,$param{$_}):()}
1185 qw(bug sourceversions arch dist version found fixed package)
1187 if (defined $presence) {
1188 if ($presence eq 'fixed') {
1189 $status{pending} = 'done';
1191 elsif ($presence eq 'absent') {
1192 $status{pending} = 'absent';
1200 my $precence = bug_presence(bug => nnn,
1204 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1205 is found, absent, fixed, or no information is available in the
1206 distribution (dist) and/or architecture (arch) specified.
1213 =item bug -- scalar bug number
1215 =item status -- optional hashref of bug status as returned by readbug
1216 (can be passed to avoid rereading the bug information)
1218 =item bug_index -- optional tied index of bug status infomration;
1219 currently not correctly implemented.
1221 =item version -- optional version to check package status at
1223 =item dist -- optional distribution to check package status at
1225 =item arch -- optional architecture to check package status at
1227 =item sourceversion -- optional arrayref of source/version; overrides
1228 dist, arch, and version. [The entries in this array must be in the
1229 "source/version" format.] Eventually this can be used to for caching.
1236 my %param = validate_with(params => \@_,
1237 spec => {bug => {type => SCALAR,
1240 status => {type => HASHREF,
1243 version => {type => SCALAR|ARRAYREF,
1246 dist => {type => SCALAR|ARRAYREF,
1249 arch => {type => SCALAR|ARRAYREF,
1252 sourceversions => {type => ARRAYREF,
1258 if (defined $param{status}) {
1259 %status = %{$param{status}};
1262 my $location = getbuglocation($param{bug}, 'summary');
1263 return {} if not length $location;
1264 %status = %{ readbug( $param{bug}, $location ) };
1268 my $pseudo_desc = getpseudodesc();
1269 if (not exists $param{sourceversions}) {
1271 # pseudopackages do not have source versions by definition.
1272 if (exists $pseudo_desc->{$status{package}}) {
1275 elsif (defined $param{version}) {
1276 foreach my $arch (make_list($param{arch})) {
1277 for my $package (split /\s*,\s*/, $status{package}) {
1278 my @temp = makesourceversions($package,
1280 make_list($param{version})
1282 @sourceversions{@temp} = (1) x @temp;
1285 } elsif (defined $param{dist}) {
1286 my %affects_distribution_tags;
1287 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1288 (1) x @{$config{affects_distribution_tags}};
1289 my $some_distributions_disallowed = 0;
1290 my %allowed_distributions;
1291 for my $tag (split ' ', ($status{keywords}||'')) {
1292 if (exists $config{distribution_aliases}{$tag} and
1293 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1294 $some_distributions_disallowed = 1;
1295 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1297 elsif (exists $affects_distribution_tags{$tag}) {
1298 $some_distributions_disallowed = 1;
1299 $allowed_distributions{$tag} = 1;
1302 my @archs = make_list(exists $param{arch}?$param{arch}:());
1303 GET_SOURCE_VERSIONS:
1304 foreach my $arch (@archs) {
1305 for my $package (split /\s*,\s*/, $status{package}) {
1308 if ($package =~ /^src:(.+)$/) {
1312 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1313 # if some distributions are disallowed,
1314 # and this isn't an allowed
1315 # distribution, then we ignore this
1316 # distribution for the purposees of
1318 if ($some_distributions_disallowed and
1319 not exists $allowed_distributions{$dist}) {
1322 push @versions, get_versions(package => $package,
1324 ($source?(arch => 'source'):
1325 (defined $arch?(arch => $arch):())),
1328 next unless @versions;
1329 my @temp = make_source_versions(package => $package,
1331 versions => \@versions,
1333 @sourceversions{@temp} = (1) x @temp;
1336 # this should really be split out into a subroutine,
1337 # but it'd touch so many things currently, that we fake
1338 # it; it's needed to properly handle bugs which are
1339 # erroneously assigned to the binary package, and we'll
1340 # probably have it go away eventually.
1341 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1343 goto GET_SOURCE_VERSIONS;
1347 # TODO: This should probably be handled further out for efficiency and
1348 # for more ease of distinguishing between pkg= and src= queries.
1349 # DLA: src= queries should just pass arch=source, and they'll be happy.
1350 @sourceversions = keys %sourceversions;
1353 @sourceversions = @{$param{sourceversions}};
1355 my $maxbuggy = 'undef';
1356 if (@sourceversions) {
1357 $maxbuggy = max_buggy(bug => $param{bug},
1358 sourceversions => \@sourceversions,
1359 found => $status{found_versions},
1360 fixed => $status{fixed_versions},
1361 package => $status{package},
1362 version_cache => $version_cache,
1365 elsif (defined $param{dist} and
1366 not exists $pseudo_desc->{$status{package}}) {
1369 if (length($status{done}) and
1370 (not @sourceversions or not @{$status{fixed_versions}})) {
1385 =item bug -- scalar bug number
1387 =item sourceversion -- optional arrayref of source/version; overrides
1388 dist, arch, and version. [The entries in this array must be in the
1389 "source/version" format.] Eventually this can be used to for caching.
1393 Note: Currently the version information is cached; this needs to be
1394 changed before using this function in long lived programs.
1399 my %param = validate_with(params => \@_,
1400 spec => {bug => {type => SCALAR,
1403 sourceversions => {type => ARRAYREF,
1406 found => {type => ARRAYREF,
1409 fixed => {type => ARRAYREF,
1412 package => {type => SCALAR,
1414 version_cache => {type => HASHREF,
1419 # Resolve bugginess states (we might be looking at multiple
1420 # architectures, say). Found wins, then fixed, then absent.
1421 my $maxbuggy = 'absent';
1422 for my $package (split /\s*,\s*/, $param{package}) {
1423 for my $version (@{$param{sourceversions}}) {
1424 my $buggy = buggy(bug => $param{bug},
1425 version => $version,
1426 found => $param{found},
1427 fixed => $param{fixed},
1428 version_cache => $param{version_cache},
1429 package => $package,
1431 if ($buggy eq 'found') {
1433 } elsif ($buggy eq 'fixed') {
1434 $maxbuggy = 'fixed';
1451 Returns the output of Debbugs::Versions::buggy for a particular
1452 package, version and found/fixed set. Automatically turns found, fixed
1453 and version into source/version strings.
1455 Caching can be had by using the version_cache, but no attempt to check
1456 to see if the on disk information is more recent than the cache is
1457 made. [This will need to be fixed for long-lived processes.]
1462 my %param = validate_with(params => \@_,
1463 spec => {bug => {type => SCALAR,
1466 found => {type => ARRAYREF,
1469 fixed => {type => ARRAYREF,
1472 version_cache => {type => HASHREF,
1475 package => {type => SCALAR,
1477 version => {type => SCALAR,
1481 my @found = @{$param{found}};
1482 my @fixed = @{$param{fixed}};
1483 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1484 # We have non-source version versions
1485 @found = makesourceversions($param{package},undef,
1488 @fixed = makesourceversions($param{package},undef,
1492 if ($param{version} !~ m{/}) {
1493 my ($version) = makesourceversions($param{package},undef,
1496 $param{version} = $version if defined $version;
1498 # Figure out which source packages we need
1500 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1501 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1502 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1503 $param{version} =~ m{/};
1505 if (not defined $param{version_cache} or
1506 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1507 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1508 foreach my $source (keys %sources) {
1509 my $srchash = substr $source, 0, 1;
1510 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1511 if (not defined $version_fh) {
1512 # We only want to warn if it's a package which actually has a maintainer
1513 my $maints = getmaintainers();
1514 next if not exists $maints->{$source};
1515 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1518 $version->load($version_fh);
1520 if (defined $param{version_cache}) {
1521 $param{version_cache}{join(',',sort keys %sources)} = $version;
1525 $version = $param{version_cache}{join(',',sort keys %sources)};
1527 return $version->buggy($param{version},\@found,\@fixed);
1530 sub isstrongseverity {
1531 my $severity = shift;
1532 $severity = $config{default_severity} if
1533 not defined $severity or $severity eq '';
1534 return grep { $_ eq $severity } @{$config{strong_severities}};
1538 =head1 PRIVATE FUNCTIONS
1542 sub update_realtime {
1543 my ($file, %bugs) = @_;
1545 # update realtime index.db
1547 return () unless keys %bugs;
1548 my $idx_old = IO::File->new($file,'r')
1549 or die "Couldn't open ${file}: $!";
1550 my $idx_new = IO::File->new($file.'.new','w')
1551 or die "Couldn't open ${file}.new: $!";
1553 my $min_bug = min(keys %bugs);
1557 while($line = <$idx_old>) {
1558 @line = split /\s/, $line;
1559 # Two cases; replacing existing line or adding new line
1560 if (exists $bugs{$line[1]}) {
1561 my $new = $bugs{$line[1]};
1562 delete $bugs{$line[1]};
1563 $min_bug = min(keys %bugs);
1564 if ($new eq "NOCHANGE") {
1565 print {$idx_new} $line;
1566 $changed_bugs{$line[1]} = $line;
1567 } elsif ($new eq "REMOVE") {
1568 $changed_bugs{$line[1]} = $line;
1570 print {$idx_new} $new;
1571 $changed_bugs{$line[1]} = $line;
1575 while ($line[1] > $min_bug) {
1576 print {$idx_new} $bugs{$min_bug};
1577 delete $bugs{$min_bug};
1578 last unless keys %bugs;
1579 $min_bug = min(keys %bugs);
1581 print {$idx_new} $line;
1583 last unless keys %bugs;
1585 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1587 print {$idx_new} <$idx_old>;
1592 rename("$file.new", $file);
1594 return %changed_bugs;
1597 sub bughook_archive {
1599 filelock("$config{spool_dir}/debbugs.trace.lock");
1600 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1601 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1602 map{($_,'REMOVE')} @refs);
1603 update_realtime("$config{spool_dir}/index.archive.realtime",
1609 my ( $type, %bugs_temp ) = @_;
1610 filelock("$config{spool_dir}/debbugs.trace.lock");
1613 for my $bug (keys %bugs_temp) {
1614 my $data = $bugs_temp{$bug};
1615 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1617 my $whendone = "open";
1618 my $severity = $config{default_severity};
1619 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1620 $pkglist =~ s/^,+//;
1621 $pkglist =~ s/,+$//;
1622 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1623 $whendone = "done" if defined $data->{done} and length $data->{done};
1624 $severity = $data->{severity} if length $data->{severity};
1626 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1627 $pkglist, $bug, $data->{date}, $whendone,
1628 $data->{originator}, $severity, $data->{keywords};
1631 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);