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
38 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
39 use Exporter qw(import);
41 use Params::Validate qw(validate_with :types);
42 use Debbugs::Common qw(:util :lock :quit :misc);
44 use Debbugs::Config qw(:config);
45 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
46 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
47 use Debbugs::Versions;
48 use Debbugs::Versions::Dpkg;
50 use File::Copy qw(copy);
51 use Encode qw(decode encode is_utf8);
53 use Storable qw(dclone);
54 use List::AllUtils qw(min max);
60 $DEBUG = 0 unless defined $DEBUG;
63 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
64 qw(isstrongseverity bug_presence split_status_fields),
66 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
67 qw(lock_read_all_merged_bugs),
69 write => [qw(writebug makestatus unlockwritebug)],
71 versions => [qw(addfoundversions addfixedversions),
72 qw(removefoundversions removefixedversions)
74 hook => [qw(bughook bughook_archive)],
75 indexdb => [qw(generate_index_db_line)],
76 fields => [qw(%fields)],
79 Exporter::export_ok_tags(keys %EXPORT_TAGS);
80 $EXPORT_TAGS{all} = [@EXPORT_OK];
86 readbug($bug_num,$location)
89 Reads a summary file from the archive given a bug number and a bug
90 location. Valid locations are those understood by L</getbugcomponent>
94 # these probably shouldn't be imported by most people, but
95 # Debbugs::Control needs them, so they're now exportable
96 our %fields = (originator => 'submitter',
99 msgid => 'message-id',
100 'package' => 'package',
103 forwarded => 'forwarded-to',
104 mergedwith => 'merged-with',
105 severity => 'severity',
107 found_versions => 'found-in',
108 found_date => 'found-date',
109 fixed_versions => 'fixed-in',
110 fixed_date => 'fixed-date',
112 blockedby => 'blocked-by',
113 unarchived => 'unarchived',
114 summary => 'summary',
115 outlook => 'outlook',
116 affects => 'affects',
120 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
121 my @rfc1522_fields = qw(originator subject done forwarded owner);
124 return read_bug(bug => $_[0],
125 (@_ > 1)?(location => $_[1]):()
131 read_bug(bug => $bug_num,
132 location => 'archive',
134 read_bug(summary => 'path/to/bugnum.summary');
137 A more complete function than readbug; it enables you to pass a full
138 path to the summary file instead of the bug number and/or location.
144 =item bug -- the bug number
146 =item location -- optional location which is passed to getbugcomponent
148 =item summary -- complete path to the .summary file which will be read
150 =item lock -- whether to obtain a lock for the bug to prevent
151 something modifying it while the bug has been read. You B<must> call
152 C<unfilelock();> if something not undef is returned from read_bug.
154 =item locks -- hashref of already obtained locks; incremented as new
155 locks are needed, and decremented as locks are released on particular
160 One of C<bug> or C<summary> must be passed. This function will return
161 undef on failure, and will die if improper arguments are passed.
170 {bug => {type => SCALAR,
172 # something really stupid passes negative bugnumbers
175 location => {type => SCALAR|UNDEF,
178 summary => {type => SCALAR,
181 lock => {type => BOOLEAN,
184 locks => {type => HASHREF,
188 my %param = validate_with(params => \@_,
191 die "One of bug or summary must be passed to read_bug"
192 if not exists $param{bug} and not exists $param{summary};
196 if (not defined $param{summary}) {
198 ($lref,$location) = @param{qw(bug location)};
199 if (not defined $location) {
200 $location = getbuglocation($lref,'summary');
201 return undef if not defined $location;
203 $status = getbugcomponent($lref, 'summary', $location);
204 $log = getbugcomponent($lref, 'log' , $location);
205 return undef unless defined $status;
206 return undef if not -e $status;
209 $status = $param{summary};
211 $log =~ s/\.summary$/.log/;
212 ($location) = $status =~ m/(db-h|db|archive)/;
213 ($param{bug}) = $status =~ m/(\d+)\.summary$/;
216 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
218 my $status_fh = IO::File->new($status, 'r');
219 if (not defined $status_fh) {
220 warn "Unable to open $status for reading: $!";
222 unfilelock(exists $param{locks}?$param{locks}:());
226 binmode($status_fh,':encoding(UTF-8)');
233 while (<$status_fh>) {
236 if (not defined $version and
237 /^Format-Version: ([0-9]+)/i
242 $version = 2 if not defined $version;
243 # Version 3 is the latest format version currently supported.
245 warn "Unsupported status version '$version'";
247 unfilelock(exists $param{locks}?$param{locks}:());
252 state $namemap = {reverse %fields};
253 for my $line (@lines) {
254 if ($line =~ /(\S+?): (.*)/) {
255 my ($name, $value) = (lc $1, $2);
256 # this is a bit of a hack; we should never, ever have \r
257 # or \n in the fields of status. Kill them off here.
258 # [Eventually, this should be superfluous.]
259 $value =~ s/[\r\n]//g;
260 $data{$namemap->{$name}} = $value if exists $namemap->{$name};
263 for my $field (keys %fields) {
264 $data{$field} = '' unless exists $data{$field};
267 for my $field (@rfc1522_fields) {
268 $data{$field} = decode_rfc1522($data{$field});
271 $data{severity} = $config{default_severity} if $data{severity} eq '';
272 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
273 $data{$field} = [split ' ', $data{$field}];
275 for my $field (qw(found fixed)) {
276 # create the found/fixed hashes which indicate when a
277 # particular version was marked found or marked fixed.
278 @{$data{$field}}{@{$data{"${field}_versions"}}} =
279 (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}),
280 @{$data{"${field}_date"}});
283 my $status_modified = (stat($status))[9];
284 # Add log last modified time
285 $data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9];
286 $data{last_modified} = max($status_modified,$data{log_modified});
287 $data{location} = $location;
288 $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
289 $data{bug_num} = $param{bug};
291 # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
292 # and not include this bug
293 if (defined $data{mergedwith} and
297 grep { $_ != $data{bug_num}}
299 split / /, $data{mergedwith}
305 =head2 split_status_fields
307 my @data = split_status_fields(@data);
309 Splits splittable status fields (like package, tags, blocks,
310 blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
311 passed @data intact using dclone.
313 In scalar context, returns only the first element of @data.
317 our $ditch_empty = sub{
319 my $splitter = shift @t;
320 return grep {length $_} map {split $splitter} @t;
323 my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
325 (package => \&splitpackages,
326 affects => \&splitpackages,
327 # Ideally we won't have to split source, but because some consumers of
328 # get_bug_status cannot handle arrayref, we will split it here.
329 source => \&splitpackages,
330 blocks => $ditch_empty_space,
331 blockedby => $ditch_empty_space,
332 # this isn't strictly correct, but we'll split both of them for
333 # the time being until we ditch all use of keywords everywhere
335 keywords => $ditch_empty_space,
336 tags => $ditch_empty_space,
337 found_versions => $ditch_empty_space,
338 fixed_versions => $ditch_empty_space,
339 mergedwith => $ditch_empty_space,
342 sub split_status_fields {
343 my @data = @{dclone(\@_)};
344 for my $data (@data) {
345 next if not defined $data;
346 croak "Passed an element which is not a hashref to split_status_field".ref($data) if
347 not (ref($data) and ref($data) eq 'HASH');
348 for my $field (keys %{$data}) {
349 next unless defined $data->{$field};
350 if (exists $split_fields{$field}) {
351 next if ref($data->{$field});
353 if (ref($split_fields{$field}) eq 'CODE') {
354 @elements = &{$split_fields{$field}}($data->{$field});
356 elsif (not ref($split_fields{$field}) or
357 UNIVERSAL::isa($split_fields{$field},'Regex')
359 @elements = split $split_fields{$field}, $data->{$field};
361 $data->{$field} = \@elements;
365 return wantarray?@data:$data[0];
368 =head2 join_status_fields
370 my @data = join_status_fields(@data);
372 Handles joining the splitable status fields. (Basically, the inverse
373 of split_status_fields.
375 Primarily called from makestatus, but may be useful for other
376 functions after calling split_status_fields (or for legacy functions
377 if we transition to split fields by default).
381 sub join_status_fields {
388 found_versions => ' ',
389 fixed_versions => ' ',
394 my @data = @{dclone(\@_)};
395 for my $data (@data) {
396 next if not defined $data;
397 croak "Passed an element which is not a hashref to split_status_field: ".
399 if ref($data) ne 'HASH';
400 for my $field (keys %{$data}) {
401 next unless defined $data->{$field};
402 next unless ref($data->{$field}) eq 'ARRAY';
403 next unless exists $join_fields{$field};
404 $data->{$field} = join($join_fields{$field},@{$data->{$field}});
407 return wantarray?@data:$data[0];
413 lockreadbug($bug_num,$location)
415 Performs a filelock, then reads the bug; the bug is unlocked if the
416 return is undefined, otherwise, you need to call unfilelock or
419 See readbug above for information on what this returns
424 my ($lref, $location) = @_;
425 return read_bug(bug => $lref, location => $location, lock => 1);
428 =head2 lockreadbugmerge
430 my ($locks, $data) = lockreadbugmerge($bug_num,$location);
432 Performs a filelock, then reads the bug. If the bug is merged, locks
433 the merge lock. Returns a list of the number of locks and the bug
438 sub lockreadbugmerge {
439 my $data = lockreadbug(@_);
440 if (not defined $data) {
443 if (not length $data->{mergedwith}) {
447 filelock("$config{spool_dir}/lock/merge");
448 $data = lockreadbug(@_);
449 if (not defined $data) {
456 =head2 lock_read_all_merged_bugs
458 my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
460 Performs a filelock, then reads the bug passed. If the bug is merged,
461 locks the merge lock, then reads and locks all of the other merged
462 bugs. Returns a list of the number of locks and the bug data for all
465 Will also return undef if any of the merged bugs failed to be read,
466 even if all of the others were read properly.
470 sub lock_read_all_merged_bugs {
471 my %param = validate_with(params => \@_,
472 spec => {bug => {type => SCALAR,
475 location => {type => SCALAR,
478 locks => {type => HASHREF,
484 my @data = read_bug(bug => $param{bug},
486 exists $param{location} ? (location => $param{location}):(),
487 exists $param{locks} ? (locks => $param{locks}):(),
489 if (not @data or not defined $data[0]) {
493 if (not length $data[0]->{mergedwith}) {
494 return ($locks,@data);
496 unfilelock(exists $param{locks}?$param{locks}:());
498 filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
500 @data = read_bug(bug => $param{bug},
502 exists $param{location} ? (location => $param{location}):(),
503 exists $param{locks} ? (locks => $param{locks}):(),
505 if (not @data or not defined $data[0]) {
506 unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
511 my @bugs = split / /, $data[0]->{mergedwith};
512 push @bugs, $param{bug};
513 for my $bug (@bugs) {
515 if ($bug != $param{bug}) {
517 read_bug(bug => $bug,
519 exists $param{location} ? (location => $param{location}):(),
520 exists $param{locks} ? (locks => $param{locks}):(),
522 if (not defined $newdata) {
524 unfilelock(exists $param{locks}?$param{locks}:());
527 warn "Unable to read bug: $bug while handling merged bug: $param{bug}";
532 # perform a sanity check to make sure that the merged bugs
533 # are all merged with eachother
534 # We do a cmp sort instead of an <=> sort here, because that's
537 join(' ',grep {$_ != $bug }
540 if ($newdata->{mergedwith} ne $expectmerge) {
542 unfilelock(exists $param{locks}?$param{locks}:());
544 die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")";
548 return ($locks,@data);
553 my $new_bug_num = new_bug(copy => $data->{bug_num});
555 Creates a new bug and returns the new bug number upon success.
563 validate_with(params => \@_,
564 spec => {copy => {type => SCALAR,
570 filelock("nextnumber.lock");
571 my $nn_fh = IO::File->new("nextnumber",'r') or
572 die "Unable to open nextnuber for reading: $!";
575 ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$';
577 overwritefile("nextnumber",
580 my $nn_hash = get_hashname($nn);
582 my $c_hash = get_hashname($param{copy});
583 for my $file (qw(log status summary report)) {
584 copy("db-h/$c_hash/$param{copy}.$file",
585 "db-h/$nn_hash/${nn}.$file")
589 for my $file (qw(log status summary report)) {
590 overwritefile("db-h/$nn_hash/${nn}.$file",
595 # this probably needs to be munged to do something more elegant
596 # &bughook('new', $clone, $data);
603 my @v1fieldorder = qw(originator date subject msgid package
604 keywords done forwarded mergedwith severity);
608 my $content = makestatus($status,$version)
609 my $content = makestatus($status);
611 Creates the content for a status file based on the $status hashref
614 Really only useful for writebug
616 Currently defaults to version 2 (non-encoded rfc1522 names) but will
617 eventually default to version 3. If you care, you should specify a
623 my ($data,$version) = @_;
624 $version = 3 unless defined $version;
628 my %newdata = %$data;
629 for my $field (qw(found fixed)) {
630 if (exists $newdata{$field}) {
631 $newdata{"${field}_date"} =
632 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
635 %newdata = %{join_status_fields(\%newdata)};
637 %newdata = encode_utf8_structure(%newdata);
640 for my $field (@rfc1522_fields) {
641 $newdata{$field} = encode_rfc1522($newdata{$field});
645 # this is a bit of a hack; we should never, ever have \r or \n in
646 # the fields of status. Kill them off here. [Eventually, this
647 # should be superfluous.]
648 for my $field (keys %newdata) {
649 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
653 for my $field (@v1fieldorder) {
654 if (exists $newdata{$field} and defined $newdata{$field}) {
655 $contents .= "$newdata{$field}\n";
660 } elsif ($version == 2 or $version == 3) {
661 # Version 2 or 3. Add a file format version number for the sake of
662 # further extensibility in the future.
663 $contents .= "Format-Version: $version\n";
664 for my $field (keys %fields) {
665 if (exists $newdata{$field} and defined $newdata{$field}
666 and $newdata{$field} ne '') {
667 # Output field names in proper case, e.g. 'Merged-With'.
668 my $properfield = $fields{$field};
669 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
670 my $data = $newdata{$field};
671 $contents .= "$properfield: $data\n";
680 writebug($bug_num,$status,$location,$minversion,$disablebughook)
682 Writes the bug status and summary files out.
684 Skips writing out a status file if minversion is 2
686 Does not call bughook if disablebughook is true.
691 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
694 my %outputs = (1 => 'status', 3 => 'summary');
695 for my $version (keys %outputs) {
696 next if defined $minversion and $version < $minversion;
697 my $status = getbugcomponent($ref, $outputs{$version}, $location);
698 die "can't find location for $ref" unless defined $status;
701 open $sfh,">","$status.new" or
702 die "opening $status.new: $!";
705 open $sfh,">","$status.new" or
706 die "opening $status.new: $!";
708 print {$sfh} makestatus($data, $version) or
709 die "writing $status.new: $!";
710 close($sfh) or die "closing $status.new: $!";
716 rename("$status.new",$status) || die "installing new $status: $!";
719 # $disablebughook is a bit of a hack to let format migration scripts use
720 # this function rather than having to duplicate it themselves.
721 &bughook($change,$ref,$data) unless $disablebughook;
724 =head2 unlockwritebug
726 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
728 Writes a bug, then calls unfilelock; see writebug for what these
740 The following functions are exported with the :versions tag
742 =head2 addfoundversions
744 addfoundversions($status,$package,$version,$isbinary);
746 All use of this should be phased out in favor of Debbugs::Control::fixed/found
751 sub addfoundversions {
755 my $isbinary = shift;
756 return unless defined $version;
757 undef $package if defined $package and $package =~ m[(?:\s|/)];
758 my $source = $package;
759 if (defined $package and $package =~ s/^src://) {
764 if (defined $package and $isbinary) {
765 my @srcinfo = binary_to_source(binary => $package,
766 version => $version);
768 # We know the source package(s). Use a fully-qualified version.
769 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
772 # Otherwise, an unqualified version will have to do.
776 # Strip off various kinds of brain-damage.
778 $version =~ s/ *\(.*\)//;
779 $version =~ s/ +[A-Za-z].*//;
781 foreach my $ver (split /[,\s]+/, $version) {
782 my $sver = defined($source) ? "$source/$ver" : '';
783 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
784 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
786 @{$data->{fixed_versions}} =
787 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
791 =head2 removefoundversions
793 removefoundversions($data,$package,$versiontoremove)
795 Removes found versions from $data
797 If a version is fully qualified (contains /) only versions matching
798 exactly are removed. Otherwise, all versions matching the version
801 Currently $package and $isbinary are entirely ignored, but accepted
802 for backwards compatibility.
806 sub removefoundversions {
810 my $isbinary = shift;
811 return unless defined $version;
813 foreach my $ver (split /[,\s]+/, $version) {
815 # fully qualified version
816 @{$data->{found_versions}} =
818 @{$data->{found_versions}};
821 # non qualified version; delete all matchers
822 @{$data->{found_versions}} =
823 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
824 @{$data->{found_versions}};
830 sub addfixedversions {
834 my $isbinary = shift;
835 return unless defined $version;
836 undef $package if defined $package and $package =~ m[(?:\s|/)];
837 my $source = $package;
839 if (defined $package and $isbinary) {
840 my @srcinfo = binary_to_source(binary => $package,
841 version => $version);
843 # We know the source package(s). Use a fully-qualified version.
844 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
847 # Otherwise, an unqualified version will have to do.
851 # Strip off various kinds of brain-damage.
853 $version =~ s/ *\(.*\)//;
854 $version =~ s/ +[A-Za-z].*//;
856 foreach my $ver (split /[,\s]+/, $version) {
857 my $sver = defined($source) ? "$source/$ver" : '';
858 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
859 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
861 @{$data->{found_versions}} =
862 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
866 sub removefixedversions {
870 my $isbinary = shift;
871 return unless defined $version;
873 foreach my $ver (split /[,\s]+/, $version) {
875 # fully qualified version
876 @{$data->{fixed_versions}} =
878 @{$data->{fixed_versions}};
881 # non qualified version; delete all matchers
882 @{$data->{fixed_versions}} =
883 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
884 @{$data->{fixed_versions}};
895 Split a package string from the status file into a list of package names.
901 return unless defined $pkgs;
902 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
906 =head2 bug_archiveable
908 bug_archiveable(bug => $bug_num);
914 =item bug -- bug number (required)
916 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
918 =item version -- Debbugs::Version information (optional)
920 =item days_until -- return days until the bug can be archived
924 Returns 1 if the bug can be archived
925 Returns 0 if the bug cannot be archived
927 If days_until is true, returns the number of days until the bug can be
928 archived, -1 if it cannot be archived. 0 means that the bug can be
929 archived the next time the archiver runs.
931 Returns undef on failure.
935 # This will eventually need to be fixed before we start using mod_perl
936 our $version_cache = {};
938 my %param = validate_with(params => \@_,
939 spec => {bug => {type => SCALAR,
942 status => {type => HASHREF,
945 days_until => {type => BOOLEAN,
948 ignore_time => {type => BOOLEAN,
953 # This is what we return if the bug cannot be archived.
954 my $cannot_archive = $param{days_until}?-1:0;
955 # read the status information
956 my $status = $param{status};
957 if (not exists $param{status} or not defined $status) {
958 $status = read_bug(bug=>$param{bug});
959 if (not defined $status) {
960 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
964 # Bugs can be archived if they are
966 if (not defined $status->{done} or not length $status->{done}) {
967 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
968 return $cannot_archive
970 # Check to make sure that the bug has none of the unremovable tags set
971 if (@{$config{removal_unremovable_tags}}) {
972 for my $tag (split ' ', ($status->{keywords}||'')) {
973 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
974 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
975 return $cannot_archive;
980 # If we just are checking if the bug can be archived, we'll not even bother
981 # checking the versioning information if the bug has been -done for less than 28 days.
982 my $log_file = getbugcomponent($param{bug},'log');
983 if (not defined $log_file) {
984 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
985 return $cannot_archive;
987 my $max_log_age = max(map {$config{remove_age} - -M $_}
988 $log_file, map {my $log = getbugcomponent($_,'log');
989 defined $log ? ($log) : ();
991 split / /, $status->{mergedwith}
993 if (not $param{days_until} and not $param{ignore_time}
996 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
997 return $cannot_archive;
999 # At this point, we have to get the versioning information for this bug.
1000 # We examine the set of distribution tags. If a bug has no distribution
1001 # tags set, we assume a default set, otherwise we use the tags the bug
1004 # In cases where we are assuming a default set, if the severity
1005 # is strong, we use the strong severity default; otherwise, we
1006 # use the normal default.
1008 # There must be fixed_versions for us to look at the versioning
1010 my $min_fixed_time = time;
1011 my $min_archive_days = 0;
1012 if (@{$status->{fixed_versions}}) {
1014 @dist_tags{@{$config{removal_distribution_tags}}} =
1015 (1) x @{$config{removal_distribution_tags}};
1017 for my $tag (split ' ', ($status->{keywords}||'')) {
1018 next unless exists $config{distribution_aliases}{$tag};
1019 next unless $dist_tags{$config{distribution_aliases}{$tag}};
1020 $dists{$config{distribution_aliases}{$tag}} = 1;
1022 if (not keys %dists) {
1023 if (isstrongseverity($status->{severity})) {
1024 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1025 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1028 @dists{@{$config{removal_default_distribution_tags}}} =
1029 (1) x @{$config{removal_default_distribution_tags}};
1032 my %source_versions;
1033 my @sourceversions = get_versions(package => $status->{package},
1034 dist => [keys %dists],
1037 @source_versions{@sourceversions} = (1) x @sourceversions;
1038 # If the bug has not been fixed in the versions actually
1039 # distributed, then it cannot be archived.
1040 if ('found' eq max_buggy(bug => $param{bug},
1041 sourceversions => [keys %source_versions],
1042 found => $status->{found_versions},
1043 fixed => $status->{fixed_versions},
1044 version_cache => $version_cache,
1045 package => $status->{package},
1047 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1048 return $cannot_archive;
1050 # Since the bug has at least been fixed in the architectures
1051 # that matters, we check to see how long it has been fixed.
1053 # If $param{ignore_time}, then we should ignore time.
1054 if ($param{ignore_time}) {
1055 return $param{days_until}?0:1;
1058 # To do this, we order the times from most recent to oldest;
1059 # when we come to the first found version, we stop.
1060 # If we run out of versions, we only report the time of the
1062 my %time_versions = get_versions(package => $status->{package},
1063 dist => [keys %dists],
1067 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1068 my $buggy = buggy(bug => $param{bug},
1069 version => $version,
1070 found => $status->{found_versions},
1071 fixed => $status->{fixed_versions},
1072 version_cache => $version_cache,
1073 package => $status->{package},
1075 last if $buggy eq 'found';
1076 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1078 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1079 # if there are no versions in the archive at all, then
1080 # we can archive if enough days have passed
1083 # If $param{ignore_time}, then we should ignore time.
1084 if ($param{ignore_time}) {
1085 return $param{days_until}?0:1;
1087 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1088 my $age = ceil($max_log_age);
1089 if ($age > 0 or $min_archive_days > 0) {
1090 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1091 return $param{days_until}?max($age,$min_archive_days):0;
1094 return $param{days_until}?0:1;
1099 =head2 get_bug_status
1101 my $status = get_bug_status(bug => $nnn);
1103 my $status = get_bug_status($bug_num)
1109 =item bug -- scalar bug number
1111 =item status -- optional hashref of bug status as returned by readbug
1112 (can be passed to avoid rereading the bug information)
1114 =item bug_index -- optional tied index of bug status infomration;
1115 currently not correctly implemented.
1117 =item version -- optional version(s) to check package status at
1119 =item dist -- optional distribution(s) to check package status at
1121 =item arch -- optional architecture(s) to check package status at
1123 =item bugusertags -- optional hashref of bugusertags
1125 =item sourceversion -- optional arrayref of source/version; overrides
1126 dist, arch, and version. [The entries in this array must be in the
1127 "source/version" format.] Eventually this can be used to for caching.
1129 =item indicatesource -- if true, indicate which source packages this
1130 bug could belong to (or does belong to in the case of bugs assigned to
1131 a source package). Defaults to true.
1135 Note: Currently the version information is cached; this needs to be
1136 changed before using this function in long lived programs.
1140 Currently returns a hashref of status with the following keys.
1144 =item id -- bug number
1146 =item bug_num -- duplicate of id
1148 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1150 =item tags -- duplicate of keywords
1152 =item package -- name of package that the bug is assigned to
1154 =item severity -- severity of the bug
1156 =item pending -- pending state of the bug; one of following possible
1157 values; values listed later have precedence if multiple conditions are
1162 =item pending -- default state
1164 =item forwarded -- bug has been forwarded
1166 =item pending-fixed -- bug is tagged pending
1168 =item fixed -- bug is tagged fixed
1170 =item absent -- bug does not apply to this distribution/architecture
1172 =item done -- bug is resolved in this distribution/architecture
1176 =item location -- db-h or archive; the location in the filesystem
1178 =item subject -- title of the bug
1180 =item last_modified -- epoch that the bug was last modified
1182 =item date -- epoch that the bug was filed
1184 =item originator -- bug reporter
1186 =item log_modified -- epoch that the log file was last modified
1188 =item msgid -- Message id of the original bug report
1193 Other key/value pairs are returned but are not currently documented here.
1197 sub get_bug_status {
1202 {bug => {type => SCALAR,
1205 status => {type => HASHREF,
1208 bug_index => {type => OBJECT,
1211 version => {type => SCALAR|ARRAYREF,
1214 dist => {type => SCALAR|ARRAYREF,
1217 arch => {type => SCALAR|ARRAYREF,
1220 bugusertags => {type => HASHREF,
1223 sourceversions => {type => ARRAYREF,
1226 indicatesource => {type => BOOLEAN,
1229 binary_to_source_cache => {type => HASHREF,
1233 my %param = validate_with(params => \@_,
1238 if (defined $param{bug_index} and
1239 exists $param{bug_index}{$param{bug}}) {
1240 %status = %{ $param{bug_index}{$param{bug}} };
1241 $status{pending} = $status{ status };
1242 $status{id} = $param{bug};
1245 if (defined $param{status}) {
1246 %status = %{$param{status}};
1249 my $location = getbuglocation($param{bug}, 'summary');
1250 return {} if not defined $location or not length $location;
1251 %status = %{ readbug( $param{bug}, $location ) };
1253 $status{id} = $param{bug};
1255 if (defined $param{bugusertags}{$param{bug}}) {
1256 $status{keywords} = "" unless defined $status{keywords};
1257 $status{keywords} .= " " unless $status{keywords} eq "";
1258 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1260 $status{tags} = $status{keywords};
1261 my %tags = map { $_ => 1 } split ' ', $status{tags};
1263 $status{package} = '' if not defined $status{package};
1264 $status{"package"} =~ s/\s*$//;
1266 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1268 exists $param{binary_to_source_cache}?
1269 (cache =>$param{binary_to_source_cache}):(),
1272 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1273 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1275 $status{"pending"} = 'pending';
1276 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1277 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1278 $status{"pending"} = 'fixed' if ($tags{fixed});
1281 my $presence = bug_presence(status => \%status,
1282 map{(exists $param{$_})?($_,$param{$_}):()}
1283 qw(bug sourceversions arch dist version found fixed package)
1285 if (defined $presence) {
1286 if ($presence eq 'fixed') {
1287 $status{pending} = 'done';
1289 elsif ($presence eq 'absent') {
1290 $status{pending} = 'absent';
1298 my $precence = bug_presence(bug => nnn,
1302 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1303 is found, absent, fixed, or no information is available in the
1304 distribution (dist) and/or architecture (arch) specified.
1311 =item bug -- scalar bug number
1313 =item status -- optional hashref of bug status as returned by readbug
1314 (can be passed to avoid rereading the bug information)
1316 =item bug_index -- optional tied index of bug status infomration;
1317 currently not correctly implemented.
1319 =item version -- optional version to check package status at
1321 =item dist -- optional distribution to check package status at
1323 =item arch -- optional architecture to check package status at
1325 =item sourceversion -- optional arrayref of source/version; overrides
1326 dist, arch, and version. [The entries in this array must be in the
1327 "source/version" format.] Eventually this can be used to for caching.
1334 my %param = validate_with(params => \@_,
1335 spec => {bug => {type => SCALAR,
1338 status => {type => HASHREF,
1341 version => {type => SCALAR|ARRAYREF,
1344 dist => {type => SCALAR|ARRAYREF,
1347 arch => {type => SCALAR|ARRAYREF,
1350 sourceversions => {type => ARRAYREF,
1356 if (defined $param{status}) {
1357 %status = %{$param{status}};
1360 my $location = getbuglocation($param{bug}, 'summary');
1361 return {} if not length $location;
1362 %status = %{ readbug( $param{bug}, $location ) };
1366 my $pseudo_desc = getpseudodesc();
1367 if (not exists $param{sourceversions}) {
1369 # pseudopackages do not have source versions by definition.
1370 if (exists $pseudo_desc->{$status{package}}) {
1373 elsif (defined $param{version}) {
1374 foreach my $arch (make_list($param{arch})) {
1375 for my $package (split /\s*,\s*/, $status{package}) {
1376 my @temp = makesourceversions($package,
1378 make_list($param{version})
1380 @sourceversions{@temp} = (1) x @temp;
1383 } elsif (defined $param{dist}) {
1384 my %affects_distribution_tags;
1385 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1386 (1) x @{$config{affects_distribution_tags}};
1387 my $some_distributions_disallowed = 0;
1388 my %allowed_distributions;
1389 for my $tag (split ' ', ($status{keywords}||'')) {
1390 if (exists $config{distribution_aliases}{$tag} and
1391 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1392 $some_distributions_disallowed = 1;
1393 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1395 elsif (exists $affects_distribution_tags{$tag}) {
1396 $some_distributions_disallowed = 1;
1397 $allowed_distributions{$tag} = 1;
1400 my @archs = make_list(exists $param{arch}?$param{arch}:());
1401 GET_SOURCE_VERSIONS:
1402 foreach my $arch (@archs) {
1403 for my $package (split /\s*,\s*/, $status{package}) {
1406 if ($package =~ /^src:(.+)$/) {
1410 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1411 # if some distributions are disallowed,
1412 # and this isn't an allowed
1413 # distribution, then we ignore this
1414 # distribution for the purposees of
1416 if ($some_distributions_disallowed and
1417 not exists $allowed_distributions{$dist}) {
1420 push @versions, get_versions(package => $package,
1422 ($source?(arch => 'source'):
1423 (defined $arch?(arch => $arch):())),
1426 next unless @versions;
1427 my @temp = make_source_versions(package => $package,
1429 versions => \@versions,
1431 @sourceversions{@temp} = (1) x @temp;
1434 # this should really be split out into a subroutine,
1435 # but it'd touch so many things currently, that we fake
1436 # it; it's needed to properly handle bugs which are
1437 # erroneously assigned to the binary package, and we'll
1438 # probably have it go away eventually.
1439 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1441 goto GET_SOURCE_VERSIONS;
1445 # TODO: This should probably be handled further out for efficiency and
1446 # for more ease of distinguishing between pkg= and src= queries.
1447 # DLA: src= queries should just pass arch=source, and they'll be happy.
1448 @sourceversions = keys %sourceversions;
1451 @sourceversions = @{$param{sourceversions}};
1453 my $maxbuggy = 'undef';
1454 if (@sourceversions) {
1455 $maxbuggy = max_buggy(bug => $param{bug},
1456 sourceversions => \@sourceversions,
1457 found => $status{found_versions},
1458 fixed => $status{fixed_versions},
1459 package => $status{package},
1460 version_cache => $version_cache,
1463 elsif (defined $param{dist} and
1464 not exists $pseudo_desc->{$status{package}}) {
1467 if (length($status{done}) and
1468 (not @sourceversions or not @{$status{fixed_versions}})) {
1483 =item bug -- scalar bug number
1485 =item sourceversion -- optional arrayref of source/version; overrides
1486 dist, arch, and version. [The entries in this array must be in the
1487 "source/version" format.] Eventually this can be used to for caching.
1491 Note: Currently the version information is cached; this needs to be
1492 changed before using this function in long lived programs.
1497 my %param = validate_with(params => \@_,
1498 spec => {bug => {type => SCALAR,
1501 sourceversions => {type => ARRAYREF,
1504 found => {type => ARRAYREF,
1507 fixed => {type => ARRAYREF,
1510 package => {type => SCALAR,
1512 version_cache => {type => HASHREF,
1517 # Resolve bugginess states (we might be looking at multiple
1518 # architectures, say). Found wins, then fixed, then absent.
1519 my $maxbuggy = 'absent';
1520 for my $package (split /\s*,\s*/, $param{package}) {
1521 for my $version (@{$param{sourceversions}}) {
1522 my $buggy = buggy(bug => $param{bug},
1523 version => $version,
1524 found => $param{found},
1525 fixed => $param{fixed},
1526 version_cache => $param{version_cache},
1527 package => $package,
1529 if ($buggy eq 'found') {
1531 } elsif ($buggy eq 'fixed') {
1532 $maxbuggy = 'fixed';
1549 Returns the output of Debbugs::Versions::buggy for a particular
1550 package, version and found/fixed set. Automatically turns found, fixed
1551 and version into source/version strings.
1553 Caching can be had by using the version_cache, but no attempt to check
1554 to see if the on disk information is more recent than the cache is
1555 made. [This will need to be fixed for long-lived processes.]
1560 my %param = validate_with(params => \@_,
1561 spec => {bug => {type => SCALAR,
1564 found => {type => ARRAYREF,
1567 fixed => {type => ARRAYREF,
1570 version_cache => {type => HASHREF,
1573 package => {type => SCALAR,
1575 version => {type => SCALAR,
1579 my @found = @{$param{found}};
1580 my @fixed = @{$param{fixed}};
1581 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1582 # We have non-source version versions
1583 @found = makesourceversions($param{package},undef,
1586 @fixed = makesourceversions($param{package},undef,
1590 if ($param{version} !~ m{/}) {
1591 my ($version) = makesourceversions($param{package},undef,
1594 $param{version} = $version if defined $version;
1596 # Figure out which source packages we need
1598 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1599 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1600 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1601 $param{version} =~ m{/};
1603 if (not defined $param{version_cache} or
1604 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1605 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1606 foreach my $source (keys %sources) {
1607 my $srchash = substr $source, 0, 1;
1608 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1609 if (not defined $version_fh) {
1610 # We only want to warn if it's a package which actually has a maintainer
1611 my $maints = getmaintainers();
1612 next if not exists $maints->{$source};
1613 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1616 $version->load($version_fh);
1618 if (defined $param{version_cache}) {
1619 $param{version_cache}{join(',',sort keys %sources)} = $version;
1623 $version = $param{version_cache}{join(',',sort keys %sources)};
1625 return $version->buggy($param{version},\@found,\@fixed);
1628 sub isstrongseverity {
1629 my $severity = shift;
1630 $severity = $config{default_severity} if
1631 not defined $severity or $severity eq '';
1632 return grep { $_ eq $severity } @{$config{strong_severities}};
1637 =head2 generate_index_db_line
1639 my $data = read_bug(bug => $bug,
1640 location => $initialdir);
1641 # generate_index_db_line hasn't been written yet at all.
1642 my $line = generate_index_db_line($data);
1644 Returns a line for a bug suitable to be written out to index.db.
1648 sub generate_index_db_line {
1649 my ($data,$bug) = @_;
1651 # just in case someone has given us a split out data
1652 $data = join_status_fields($data);
1654 my $whendone = "open";
1655 my $severity = $config{default_severity};
1656 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1657 $pkglist =~ s/^,+//;
1658 $pkglist =~ s/,+$//;
1659 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1660 $whendone = "done" if defined $data->{done} and length $data->{done};
1661 $severity = $data->{severity} if length $data->{severity};
1662 return sprintf "%s %d %d %s [%s] %s %s\n",
1663 $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1664 $data->{originator}, $severity, $data->{keywords};
1669 =head1 PRIVATE FUNCTIONS
1673 sub update_realtime {
1674 my ($file, %bugs) = @_;
1676 # update realtime index.db
1678 return () unless keys %bugs;
1679 my $idx_old = IO::File->new($file,'r')
1680 or die "Couldn't open ${file}: $!";
1681 my $idx_new = IO::File->new($file.'.new','w')
1682 or die "Couldn't open ${file}.new: $!";
1684 binmode($idx_old,':raw:utf8');
1685 binmode($idx_new,':raw:encoding(UTF-8)');
1686 my $min_bug = min(keys %bugs);
1690 while($line = <$idx_old>) {
1691 @line = split /\s/, $line;
1692 # Two cases; replacing existing line or adding new line
1693 if (exists $bugs{$line[1]}) {
1694 my $new = $bugs{$line[1]};
1695 delete $bugs{$line[1]};
1696 $min_bug = min(keys %bugs);
1697 if ($new eq "NOCHANGE") {
1698 print {$idx_new} $line;
1699 $changed_bugs{$line[1]} = $line;
1700 } elsif ($new eq "REMOVE") {
1701 $changed_bugs{$line[1]} = $line;
1703 print {$idx_new} $new;
1704 $changed_bugs{$line[1]} = $line;
1708 while ($line[1] > $min_bug) {
1709 print {$idx_new} $bugs{$min_bug};
1710 delete $bugs{$min_bug};
1711 last unless keys %bugs;
1712 $min_bug = min(keys %bugs);
1714 print {$idx_new} $line;
1716 last unless keys %bugs;
1718 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1720 print {$idx_new} <$idx_old>;
1725 rename("$file.new", $file);
1727 return %changed_bugs;
1730 sub bughook_archive {
1732 filelock("$config{spool_dir}/debbugs.trace.lock");
1733 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1734 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1735 map{($_,'REMOVE')} @refs);
1736 update_realtime("$config{spool_dir}/index.archive.realtime",
1742 my ( $type, %bugs_temp ) = @_;
1743 filelock("$config{spool_dir}/debbugs.trace.lock");
1746 for my $bug (keys %bugs_temp) {
1747 my $data = $bugs_temp{$bug};
1748 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1750 $bugs{$bug} = generate_index_db_line($data,$bug);
1752 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);