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) {
244 $line = decode("utf8",$line,Encode::FB_CROAK);
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 $data{severity} = $config{default_severity} if $data{severity} eq '';
260 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
261 $data{$field} = [split ' ', $data{$field}];
263 for my $field (qw(found fixed)) {
264 # create the found/fixed hashes which indicate when a
265 # particular version was marked found or marked fixed.
266 @{$data{$field}}{@{$data{"${field}_versions"}}} =
267 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
268 @{$data{"${field}_date"}});
272 for my $field (@rfc1522_fields) {
273 $data{$field} = decode_rfc1522($data{$field});
276 my $status_modified = (stat($status))[9];
277 # Add log last modified time
278 $data{log_modified} = (stat($log))[9];
279 $data{last_modified} = max($status_modified,$data{log_modified});
280 $data{location} = $location;
281 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
282 $data{bug_num} = $param{bug};
287 =head2 split_status_fields
289 my @data = split_status_fields(@data);
291 Splits splittable status fields (like package, tags, blocks,
292 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
293 passed @data intact using dclone.
295 In scalar context, returns only the first element of @data.
299 our $ditch_empty = sub{
301 my $splitter = shift @t;
302 return grep {length $_} map {split $splitter} @t;
305 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
307 (package => \&splitpackages,
308 affects => \&splitpackages,
309 blocks => $ditch_empty_space,
310 blockedby => $ditch_empty_space,
311 # this isn't strictly correct, but we'll split both of them for
312 # the time being until we ditch all use of keywords everywhere
314 keywords => $ditch_empty_space,
315 tags => $ditch_empty_space,
316 found_versions => $ditch_empty_space,
317 fixed_versions => $ditch_empty_space,
318 mergedwith => $ditch_empty_space,
321 sub split_status_fields {
322 my @data = @{dclone(\@_)};
323 for my $data (@data) {
324 next if not defined $data;
325 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
326 not (ref($data) and ref($data) eq 'HASH');
327 for my $field (keys %{$data}) {
328 next unless defined $data->{$field};
329 if (exists $split_fields{$field}) {
330 next if ref($data->{$field});
332 if (ref($split_fields{$field}) eq 'CODE') {
333 @elements = &{$split_fields{$field}}($data->{$field});
335 elsif (not ref($split_fields{$field}) or
336 UNIVERSAL::isa($split_fields{$field},'Regex')
338 @elements = split $split_fields{$field}, $data->{$field};
340 $data->{$field} = \@elements;
344 return wantarray?@data:$data[0];
347 =head2 join_status_fields
349 my @data = join_status_fields(@data);
351 Handles joining the splitable status fields. (Basically, the inverse
352 of split_status_fields.
354 Primarily called from makestatus, but may be useful for other
355 functions after calling split_status_fields (or for legacy functions
356 if we transition to split fields by default).
360 sub join_status_fields {
367 found_versions => ' ',
368 fixed_versions => ' ',
373 my @data = @{dclone(\@_)};
374 for my $data (@data) {
375 next if not defined $data;
376 croak "Passed an element which is not a hashref to split_status_field: ".
378 if ref($data) ne 'HASH';
379 for my $field (keys %{$data}) {
380 next unless defined $data->{$field};
381 next unless ref($data->{$field}) eq 'ARRAY';
382 next unless exists $join_fields{$field};
383 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
386 return wantarray?@data:$data[0];
392 lockreadbug($bug_num,$location)
394 Performs a filelock, then reads the bug; the bug is unlocked if the
395 return is undefined, otherwise, you need to call unfilelock or
398 See readbug above for information on what this returns
403 my ($lref, $location) = @_;
404 return read_bug(bug => $lref, location => $location, lock => 1);
407 =head2 lockreadbugmerge
409 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
411 Performs a filelock, then reads the bug. If the bug is merged, locks
412 the merge lock. Returns a list of the number of locks and the bug
417 sub lockreadbugmerge {
418 my ($bug_num,$location) = @_;
419 my $data = lockreadbug(@_);
420 if (not defined $data) {
423 if (not length $data->{mergedwith}) {
427 filelock("$config{spool_dir}/lock/merge");
428 $data = lockreadbug(@_);
429 if (not defined $data) {
436 =head2 lock_read_all_merged_bugs
438 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
440 Performs a filelock, then reads the bug passed. If the bug is merged,
441 locks the merge lock, then reads and locks all of the other merged
442 bugs. Returns a list of the number of locks and the bug data for all
445 Will also return undef if any of the merged bugs failed to be read,
446 even if all of the others were read properly.
450 sub lock_read_all_merged_bugs {
451 my %param = validate_with(params => \@_,
452 spec => {bug => {type => SCALAR,
455 location => {type => SCALAR,
458 locks => {type => HASHREF,
464 my @data = read_bug(bug => $param{bug},
466 exists $param{location} ? (location => $param{location}):(),
467 exists $param{locks} ? (locks => $param{locks}):(),
469 if (not @data or not defined $data[0]) {
473 if (not length $data[0]->{mergedwith}) {
474 return ($locks,@data);
476 unfilelock(exists $param{locks}?$param{locks}:());
478 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
480 @data = read_bug(bug => $param{bug},
482 exists $param{location} ? (location => $param{location}):(),
483 exists $param{locks} ? (locks => $param{locks}):(),
485 if (not @data or not defined $data[0]) {
486 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
491 my @bugs = split / /, $data[0]->{mergedwith};
492 push @bugs, $param{bug};
493 for my $bug (@bugs) {
495 if ($bug != $param{bug}) {
497 read_bug(bug => $bug,
499 exists $param{location} ? (location => $param{location}):(),
500 exists $param{locks} ? (locks => $param{locks}):(),
502 if (not defined $newdata) {
504 unfilelock(exists $param{locks}?$param{locks}:());
507 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
512 # perform a sanity check to make sure that the merged bugs
513 # are all merged with eachother
514 my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } @bugs);
515 if ($newdata->{mergedwith} ne $expectmerge) {
517 unfilelock(exists $param{locks}?$param{locks}:());
519 die "Bug $param{bug} differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
523 return ($locks,@data);
528 my $new_bug_num = new_bug(copy => $data->{bug_num});
530 Creates a new bug and returns the new bug number upon success.
538 validate_with(params => \@_,
539 spec => {copy => {type => SCALAR,
545 filelock("nextnumber.lock");
546 my $nn_fh = IO::File->new("nextnumber",'r') or
547 die "Unable to open nextnuber for reading: $!";
550 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
552 overwritefile("nextnumber",
555 my $nn_hash = get_hashname($nn);
557 my $c_hash = get_hashname($param{copy});
558 for my $file (qw(log status summary report)) {
559 copy("db-h/$c_hash/$param{copy}.$file",
560 "db-h/$nn_hash/${nn}.$file")
564 for my $file (qw(log status summary report)) {
565 overwritefile("db-h/$nn_hash/${nn}.$file",
570 # this probably needs to be munged to do something more elegant
571 # &bughook('new', $clone, $data);
578 my @v1fieldorder = qw(originator date subject msgid package
579 keywords done forwarded mergedwith severity);
583 my $content = makestatus($status,$version)
584 my $content = makestatus($status);
586 Creates the content for a status file based on the $status hashref
589 Really only useful for writebug
591 Currently defaults to version 2 (non-encoded rfc1522 names) but will
592 eventually default to version 3. If you care, you should specify a
598 my ($data,$version) = @_;
599 $version = 2 unless defined $version;
603 my %newdata = %$data;
604 for my $field (qw(found fixed)) {
605 if (exists $newdata{$field}) {
606 $newdata{"${field}_date"} =
607 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
610 %newdata = %{join_status_fields(\%newdata)};
613 for my $field (@rfc1522_fields) {
614 $newdata{$field} = encode_rfc1522($newdata{$field});
618 # this is a bit of a hack; we should never, ever have \r or \n in
619 # the fields of status. Kill them off here. [Eventually, this
620 # should be superfluous.]
621 for my $field (keys %newdata) {
622 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
626 for my $field (@v1fieldorder) {
627 if (exists $newdata{$field} and defined $newdata{$field}) {
628 $contents .= "$newdata{$field}\n";
633 } elsif ($version == 2 or $version == 3) {
634 # Version 2 or 3. Add a file format version number for the sake of
635 # further extensibility in the future.
636 $contents .= "Format-Version: $version\n";
637 for my $field (keys %fields) {
638 if (exists $newdata{$field} and defined $newdata{$field}
639 and $newdata{$field} ne '') {
640 # Output field names in proper case, e.g. 'Merged-With'.
641 my $properfield = $fields{$field};
642 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
643 my $data = $newdata{$field};
644 $contents .= "$properfield: $data\n";
649 $contents = encode("utf8",$contents,Encode::FB_CROAK);
656 writebug($bug_num,$status,$location,$minversion,$disablebughook)
658 Writes the bug status and summary files out.
660 Skips writting out a status file if minversion is 2
662 Does not call bughook if disablebughook is true.
667 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
670 my %outputs = (1 => 'status', 2 => 'summary');
671 for my $version (keys %outputs) {
672 next if defined $minversion and $version < $minversion;
673 my $status = getbugcomponent($ref, $outputs{$version}, $location);
674 die "can't find location for $ref" unless defined $status;
675 open(S,"> $status.new") || die "opening $status.new: $!";
676 print(S makestatus($data, $version)) ||
677 die "writing $status.new: $!";
678 close(S) || die "closing $status.new: $!";
684 rename("$status.new",$status) || die "installing new $status: $!";
687 # $disablebughook is a bit of a hack to let format migration scripts use
688 # this function rather than having to duplicate it themselves.
689 &bughook($change,$ref,$data) unless $disablebughook;
692 =head2 unlockwritebug
694 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
696 Writes a bug, then calls unfilelock; see writebug for what these
708 The following functions are exported with the :versions tag
710 =head2 addfoundversions
712 addfoundversions($status,$package,$version,$isbinary);
714 All use of this should be phased out in favor of Debbugs::Control::fixed/found
719 sub addfoundversions {
723 my $isbinary = shift;
724 return unless defined $version;
725 undef $package if $package =~ m[(?:\s|/)];
726 my $source = $package;
727 if ($package =~ s/^src://) {
732 if (defined $package and $isbinary) {
733 my @srcinfo = binary_to_source(binary => $package,
734 version => $version);
736 # We know the source package(s). Use a fully-qualified version.
737 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
740 # Otherwise, an unqualified version will have to do.
744 # Strip off various kinds of brain-damage.
746 $version =~ s/ *\(.*\)//;
747 $version =~ s/ +[A-Za-z].*//;
749 foreach my $ver (split /[,\s]+/, $version) {
750 my $sver = defined($source) ? "$source/$ver" : '';
751 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
752 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
754 @{$data->{fixed_versions}} =
755 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
759 =head2 removefoundversions
761 removefoundversions($data,$package,$versiontoremove)
763 Removes found versions from $data
765 If a version is fully qualified (contains /) only versions matching
766 exactly are removed. Otherwise, all versions matching the version
769 Currently $package and $isbinary are entirely ignored, but accepted
770 for backwards compatibilty.
774 sub removefoundversions {
778 my $isbinary = shift;
779 return unless defined $version;
781 foreach my $ver (split /[,\s]+/, $version) {
783 # fully qualified version
784 @{$data->{found_versions}} =
786 @{$data->{found_versions}};
789 # non qualified version; delete all matchers
790 @{$data->{found_versions}} =
791 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
792 @{$data->{found_versions}};
798 sub addfixedversions {
802 my $isbinary = shift;
803 return unless defined $version;
804 undef $package if defined $package and $package =~ m[(?:\s|/)];
805 my $source = $package;
807 if (defined $package and $isbinary) {
808 my @srcinfo = binary_to_source(binary => $package,
809 version => $version);
811 # We know the source package(s). Use a fully-qualified version.
812 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
815 # Otherwise, an unqualified version will have to do.
819 # Strip off various kinds of brain-damage.
821 $version =~ s/ *\(.*\)//;
822 $version =~ s/ +[A-Za-z].*//;
824 foreach my $ver (split /[,\s]+/, $version) {
825 my $sver = defined($source) ? "$source/$ver" : '';
826 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
827 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
829 @{$data->{found_versions}} =
830 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
834 sub removefixedversions {
838 my $isbinary = shift;
839 return unless defined $version;
841 foreach my $ver (split /[,\s]+/, $version) {
843 # fully qualified version
844 @{$data->{fixed_versions}} =
846 @{$data->{fixed_versions}};
849 # non qualified version; delete all matchers
850 @{$data->{fixed_versions}} =
851 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
852 @{$data->{fixed_versions}};
863 Split a package string from the status file into a list of package names.
869 return unless defined $pkgs;
870 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
874 =head2 bug_archiveable
876 bug_archiveable(bug => $bug_num);
882 =item bug -- bug number (required)
884 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
886 =item version -- Debbugs::Version information (optional)
888 =item days_until -- return days until the bug can be archived
892 Returns 1 if the bug can be archived
893 Returns 0 if the bug cannot be archived
895 If days_until is true, returns the number of days until the bug can be
896 archived, -1 if it cannot be archived. 0 means that the bug can be
897 archived the next time the archiver runs.
899 Returns undef on failure.
903 # This will eventually need to be fixed before we start using mod_perl
904 our $version_cache = {};
906 my %param = validate_with(params => \@_,
907 spec => {bug => {type => SCALAR,
910 status => {type => HASHREF,
913 days_until => {type => BOOLEAN,
916 ignore_time => {type => BOOLEAN,
921 # This is what we return if the bug cannot be archived.
922 my $cannot_archive = $param{days_until}?-1:0;
923 # read the status information
924 my $status = $param{status};
925 if (not exists $param{status} or not defined $status) {
926 $status = read_bug(bug=>$param{bug});
927 if (not defined $status) {
928 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
932 # Bugs can be archived if they are
934 if (not defined $status->{done} or not length $status->{done}) {
935 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
936 return $cannot_archive
938 # Check to make sure that the bug has none of the unremovable tags set
939 if (@{$config{removal_unremovable_tags}}) {
940 for my $tag (split ' ', ($status->{keywords}||'')) {
941 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
942 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
943 return $cannot_archive;
948 # If we just are checking if the bug can be archived, we'll not even bother
949 # checking the versioning information if the bug has been -done for less than 28 days.
950 my $log_file = getbugcomponent($param{bug},'log');
951 if (not defined $log_file) {
952 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
953 return $cannot_archive;
955 my $max_log_age = max(map {$config{remove_age} - -M $_}
956 $log_file, map {my $log = getbugcomponent($_,'log');
957 defined $log ? ($log) : ();
959 split / /, $status->{mergedwith}
961 if (not $param{days_until} and not $param{ignore_time}
964 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
965 return $cannot_archive;
967 # At this point, we have to get the versioning information for this bug.
968 # We examine the set of distribution tags. If a bug has no distribution
969 # tags set, we assume a default set, otherwise we use the tags the bug
972 # In cases where we are assuming a default set, if the severity
973 # is strong, we use the strong severity default; otherwise, we
974 # use the normal default.
976 # There must be fixed_versions for us to look at the versioning
978 my $min_fixed_time = time;
979 my $min_archive_days = 0;
980 if (@{$status->{fixed_versions}}) {
982 @dist_tags{@{$config{removal_distribution_tags}}} =
983 (1) x @{$config{removal_distribution_tags}};
985 for my $tag (split ' ', ($status->{keywords}||'')) {
986 next unless exists $config{distribution_aliases}{$tag};
987 next unless $dist_tags{$config{distribution_aliases}{$tag}};
988 $dists{$config{distribution_aliases}{$tag}} = 1;
990 if (not keys %dists) {
991 if (isstrongseverity($status->{severity})) {
992 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
993 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
996 @dists{@{$config{removal_default_distribution_tags}}} =
997 (1) x @{$config{removal_default_distribution_tags}};
1000 my %source_versions;
1001 my @sourceversions = get_versions(package => $status->{package},
1002 dist => [keys %dists],
1005 @source_versions{@sourceversions} = (1) x @sourceversions;
1006 # If the bug has not been fixed in the versions actually
1007 # distributed, then it cannot be archived.
1008 if ('found' eq max_buggy(bug => $param{bug},
1009 sourceversions => [keys %source_versions],
1010 found => $status->{found_versions},
1011 fixed => $status->{fixed_versions},
1012 version_cache => $version_cache,
1013 package => $status->{package},
1015 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1016 return $cannot_archive;
1018 # Since the bug has at least been fixed in the architectures
1019 # that matters, we check to see how long it has been fixed.
1021 # If $param{ignore_time}, then we should ignore time.
1022 if ($param{ignore_time}) {
1023 return $param{days_until}?0:1;
1026 # To do this, we order the times from most recent to oldest;
1027 # when we come to the first found version, we stop.
1028 # If we run out of versions, we only report the time of the
1030 my %time_versions = get_versions(package => $status->{package},
1031 dist => [keys %dists],
1035 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1036 my $buggy = buggy(bug => $param{bug},
1037 version => $version,
1038 found => $status->{found_versions},
1039 fixed => $status->{fixed_versions},
1040 version_cache => $version_cache,
1041 package => $status->{package},
1043 last if $buggy eq 'found';
1044 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1046 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1047 # if there are no versions in the archive at all, then
1048 # we can archive if enough days have passed
1051 # If $param{ignore_time}, then we should ignore time.
1052 if ($param{ignore_time}) {
1053 return $param{days_until}?0:1;
1055 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1056 my $age = ceil($max_log_age);
1057 if ($age > 0 or $min_archive_days > 0) {
1058 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1059 return $param{days_until}?max($age,$min_archive_days):0;
1062 return $param{days_until}?0:1;
1067 =head2 get_bug_status
1069 my $status = get_bug_status(bug => $nnn);
1071 my $status = get_bug_status($bug_num)
1077 =item bug -- scalar bug number
1079 =item status -- optional hashref of bug status as returned by readbug
1080 (can be passed to avoid rereading the bug information)
1082 =item bug_index -- optional tied index of bug status infomration;
1083 currently not correctly implemented.
1085 =item version -- optional version(s) to check package status at
1087 =item dist -- optional distribution(s) to check package status at
1089 =item arch -- optional architecture(s) to check package status at
1091 =item bugusertags -- optional hashref of bugusertags
1093 =item sourceversion -- optional arrayref of source/version; overrides
1094 dist, arch, and version. [The entries in this array must be in the
1095 "source/version" format.] Eventually this can be used to for caching.
1097 =item indicatesource -- if true, indicate which source packages this
1098 bug could belong to (or does belong to in the case of bugs assigned to
1099 a source package). Defaults to true.
1103 Note: Currently the version information is cached; this needs to be
1104 changed before using this function in long lived programs.
1108 sub get_bug_status {
1112 my %param = validate_with(params => \@_,
1113 spec => {bug => {type => SCALAR,
1116 status => {type => HASHREF,
1119 bug_index => {type => OBJECT,
1122 version => {type => SCALAR|ARRAYREF,
1125 dist => {type => SCALAR|ARRAYREF,
1128 arch => {type => SCALAR|ARRAYREF,
1131 bugusertags => {type => HASHREF,
1134 sourceversions => {type => ARRAYREF,
1137 indicatesource => {type => BOOLEAN,
1144 if (defined $param{bug_index} and
1145 exists $param{bug_index}{$param{bug}}) {
1146 %status = %{ $param{bug_index}{$param{bug}} };
1147 $status{pending} = $status{ status };
1148 $status{id} = $param{bug};
1151 if (defined $param{status}) {
1152 %status = %{$param{status}};
1155 my $location = getbuglocation($param{bug}, 'summary');
1156 return {} if not defined $location or not length $location;
1157 %status = %{ readbug( $param{bug}, $location ) };
1159 $status{id} = $param{bug};
1161 if (defined $param{bugusertags}{$param{bug}}) {
1162 $status{keywords} = "" unless defined $status{keywords};
1163 $status{keywords} .= " " unless $status{keywords} eq "";
1164 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1166 $status{tags} = $status{keywords};
1167 my %tags = map { $_ => 1 } split ' ', $status{tags};
1169 $status{package} = '' if not defined $status{package};
1170 $status{"package"} =~ s/\s*$//;
1172 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1176 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1177 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1179 $status{"pending"} = 'pending';
1180 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1181 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1182 $status{"pending"} = 'fixed' if ($tags{fixed});
1185 my $presence = bug_presence(status => \%status,
1186 map{(exists $param{$_})?($_,$param{$_}):()}
1187 qw(bug sourceversions arch dist version found fixed package)
1189 if (defined $presence) {
1190 if ($presence eq 'fixed') {
1191 $status{pending} = 'done';
1193 elsif ($presence eq 'absent') {
1194 $status{pending} = 'absent';
1202 my $precence = bug_presence(bug => nnn,
1206 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1207 is found, absent, fixed, or no information is available in the
1208 distribution (dist) and/or architecture (arch) specified.
1215 =item bug -- scalar bug number
1217 =item status -- optional hashref of bug status as returned by readbug
1218 (can be passed to avoid rereading the bug information)
1220 =item bug_index -- optional tied index of bug status infomration;
1221 currently not correctly implemented.
1223 =item version -- optional version to check package status at
1225 =item dist -- optional distribution to check package status at
1227 =item arch -- optional architecture to check package status at
1229 =item sourceversion -- optional arrayref of source/version; overrides
1230 dist, arch, and version. [The entries in this array must be in the
1231 "source/version" format.] Eventually this can be used to for caching.
1238 my %param = validate_with(params => \@_,
1239 spec => {bug => {type => SCALAR,
1242 status => {type => HASHREF,
1245 version => {type => SCALAR|ARRAYREF,
1248 dist => {type => SCALAR|ARRAYREF,
1251 arch => {type => SCALAR|ARRAYREF,
1254 sourceversions => {type => ARRAYREF,
1260 if (defined $param{status}) {
1261 %status = %{$param{status}};
1264 my $location = getbuglocation($param{bug}, 'summary');
1265 return {} if not length $location;
1266 %status = %{ readbug( $param{bug}, $location ) };
1270 my $pseudo_desc = getpseudodesc();
1271 if (not exists $param{sourceversions}) {
1273 # pseudopackages do not have source versions by definition.
1274 if (exists $pseudo_desc->{$status{package}}) {
1277 elsif (defined $param{version}) {
1278 foreach my $arch (make_list($param{arch})) {
1279 for my $package (split /\s*,\s*/, $status{package}) {
1280 my @temp = makesourceversions($package,
1282 make_list($param{version})
1284 @sourceversions{@temp} = (1) x @temp;
1287 } elsif (defined $param{dist}) {
1288 my %affects_distribution_tags;
1289 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1290 (1) x @{$config{affects_distribution_tags}};
1291 my $some_distributions_disallowed = 0;
1292 my %allowed_distributions;
1293 for my $tag (split ' ', ($status{keywords}||'')) {
1294 if (exists $config{distribution_aliases}{$tag} and
1295 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1296 $some_distributions_disallowed = 1;
1297 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1299 elsif (exists $affects_distribution_tags{$tag}) {
1300 $some_distributions_disallowed = 1;
1301 $allowed_distributions{$tag} = 1;
1304 my @archs = make_list(exists $param{arch}?$param{arch}:());
1305 GET_SOURCE_VERSIONS:
1306 foreach my $arch (@archs) {
1307 for my $package (split /\s*,\s*/, $status{package}) {
1310 if ($package =~ /^src:(.+)$/) {
1314 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1315 # if some distributions are disallowed,
1316 # and this isn't an allowed
1317 # distribution, then we ignore this
1318 # distribution for the purposees of
1320 if ($some_distributions_disallowed and
1321 not exists $allowed_distributions{$dist}) {
1324 push @versions, get_versions(package => $package,
1326 ($source?(arch => 'source'):
1327 (defined $arch?(arch => $arch):())),
1330 next unless @versions;
1331 my @temp = make_source_versions(package => $package,
1333 versions => \@versions,
1335 @sourceversions{@temp} = (1) x @temp;
1338 # this should really be split out into a subroutine,
1339 # but it'd touch so many things currently, that we fake
1340 # it; it's needed to properly handle bugs which are
1341 # erroneously assigned to the binary package, and we'll
1342 # probably have it go away eventually.
1343 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1345 goto GET_SOURCE_VERSIONS;
1349 # TODO: This should probably be handled further out for efficiency and
1350 # for more ease of distinguishing between pkg= and src= queries.
1351 # DLA: src= queries should just pass arch=source, and they'll be happy.
1352 @sourceversions = keys %sourceversions;
1355 @sourceversions = @{$param{sourceversions}};
1357 my $maxbuggy = 'undef';
1358 if (@sourceversions) {
1359 $maxbuggy = max_buggy(bug => $param{bug},
1360 sourceversions => \@sourceversions,
1361 found => $status{found_versions},
1362 fixed => $status{fixed_versions},
1363 package => $status{package},
1364 version_cache => $version_cache,
1367 elsif (defined $param{dist} and
1368 not exists $pseudo_desc->{$status{package}}) {
1371 if (length($status{done}) and
1372 (not @sourceversions or not @{$status{fixed_versions}})) {
1387 =item bug -- scalar bug number
1389 =item sourceversion -- optional arrayref of source/version; overrides
1390 dist, arch, and version. [The entries in this array must be in the
1391 "source/version" format.] Eventually this can be used to for caching.
1395 Note: Currently the version information is cached; this needs to be
1396 changed before using this function in long lived programs.
1401 my %param = validate_with(params => \@_,
1402 spec => {bug => {type => SCALAR,
1405 sourceversions => {type => ARRAYREF,
1408 found => {type => ARRAYREF,
1411 fixed => {type => ARRAYREF,
1414 package => {type => SCALAR,
1416 version_cache => {type => HASHREF,
1421 # Resolve bugginess states (we might be looking at multiple
1422 # architectures, say). Found wins, then fixed, then absent.
1423 my $maxbuggy = 'absent';
1424 for my $package (split /\s*,\s*/, $param{package}) {
1425 for my $version (@{$param{sourceversions}}) {
1426 my $buggy = buggy(bug => $param{bug},
1427 version => $version,
1428 found => $param{found},
1429 fixed => $param{fixed},
1430 version_cache => $param{version_cache},
1431 package => $package,
1433 if ($buggy eq 'found') {
1435 } elsif ($buggy eq 'fixed') {
1436 $maxbuggy = 'fixed';
1453 Returns the output of Debbugs::Versions::buggy for a particular
1454 package, version and found/fixed set. Automatically turns found, fixed
1455 and version into source/version strings.
1457 Caching can be had by using the version_cache, but no attempt to check
1458 to see if the on disk information is more recent than the cache is
1459 made. [This will need to be fixed for long-lived processes.]
1464 my %param = validate_with(params => \@_,
1465 spec => {bug => {type => SCALAR,
1468 found => {type => ARRAYREF,
1471 fixed => {type => ARRAYREF,
1474 version_cache => {type => HASHREF,
1477 package => {type => SCALAR,
1479 version => {type => SCALAR,
1483 my @found = @{$param{found}};
1484 my @fixed = @{$param{fixed}};
1485 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1486 # We have non-source version versions
1487 @found = makesourceversions($param{package},undef,
1490 @fixed = makesourceversions($param{package},undef,
1494 if ($param{version} !~ m{/}) {
1495 my ($version) = makesourceversions($param{package},undef,
1498 $param{version} = $version if defined $version;
1500 # Figure out which source packages we need
1502 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1503 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1504 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1505 $param{version} =~ m{/};
1507 if (not defined $param{version_cache} or
1508 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1509 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1510 foreach my $source (keys %sources) {
1511 my $srchash = substr $source, 0, 1;
1512 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1513 if (not defined $version_fh) {
1514 # We only want to warn if it's a package which actually has a maintainer
1515 my $maints = getmaintainers();
1516 next if not exists $maints->{$source};
1517 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1520 $version->load($version_fh);
1522 if (defined $param{version_cache}) {
1523 $param{version_cache}{join(',',sort keys %sources)} = $version;
1527 $version = $param{version_cache}{join(',',sort keys %sources)};
1529 return $version->buggy($param{version},\@found,\@fixed);
1532 sub isstrongseverity {
1533 my $severity = shift;
1534 $severity = $config{default_severity} if
1535 not defined $severity or $severity eq '';
1536 return grep { $_ eq $severity } @{$config{strong_severities}};
1540 =head1 PRIVATE FUNCTIONS
1544 sub update_realtime {
1545 my ($file, %bugs) = @_;
1547 # update realtime index.db
1549 return () unless keys %bugs;
1550 my $idx_old = IO::File->new($file,'r')
1551 or die "Couldn't open ${file}: $!";
1552 my $idx_new = IO::File->new($file.'.new','w')
1553 or die "Couldn't open ${file}.new: $!";
1555 my $min_bug = min(keys %bugs);
1559 while($line = <$idx_old>) {
1560 @line = split /\s/, $line;
1561 # Two cases; replacing existing line or adding new line
1562 if (exists $bugs{$line[1]}) {
1563 my $new = $bugs{$line[1]};
1564 delete $bugs{$line[1]};
1565 $min_bug = min(keys %bugs);
1566 if ($new eq "NOCHANGE") {
1567 print {$idx_new} $line;
1568 $changed_bugs{$line[1]} = $line;
1569 } elsif ($new eq "REMOVE") {
1570 $changed_bugs{$line[1]} = $line;
1572 print {$idx_new} $new;
1573 $changed_bugs{$line[1]} = $line;
1577 while ($line[1] > $min_bug) {
1578 print {$idx_new} $bugs{$min_bug};
1579 delete $bugs{$min_bug};
1580 last unless keys %bugs;
1581 $min_bug = min(keys %bugs);
1583 print {$idx_new} $line;
1585 last unless keys %bugs;
1587 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1589 print {$idx_new} <$idx_old>;
1594 rename("$file.new", $file);
1596 return %changed_bugs;
1599 sub bughook_archive {
1601 filelock("$config{spool_dir}/debbugs.trace.lock");
1602 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1603 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1604 map{($_,'REMOVE')} @refs);
1605 update_realtime("$config{spool_dir}/index.archive.realtime",
1611 my ( $type, %bugs_temp ) = @_;
1612 filelock("$config{spool_dir}/debbugs.trace.lock");
1615 for my $bug (keys %bugs_temp) {
1616 my $data = $bugs_temp{$bug};
1617 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1619 my $whendone = "open";
1620 my $severity = $config{default_severity};
1621 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1622 $pkglist =~ s/^,+//;
1623 $pkglist =~ s/,+$//;
1624 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1625 $whendone = "done" if defined $data->{done} and length $data->{done};
1626 $severity = $data->{severity} if length $data->{severity};
1628 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1629 $pkglist, $bug, $data->{date}, $whendone,
1630 $data->{originator}, $severity, $data->{keywords};
1633 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);