1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Status;
14 Debbugs::Status -- Routines for dealing with summary and status files
23 This module is a replacement for the parts of errorlib.pl which write
24 and read status and summary files.
26 It also contains generic routines for returning information about the
27 status of a particular bug
36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
37 use base qw(Exporter);
39 use Params::Validate qw(validate_with :types);
40 use Debbugs::Common qw(:util :lock :quit :misc);
42 use Debbugs::Config qw(:config);
43 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
44 use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source);
45 use Debbugs::Versions;
46 use Debbugs::Versions::Dpkg;
48 use File::Copy qw(copy);
49 use Encode qw(decode encode is_utf8);
51 use Storable qw(dclone);
52 use List::Util qw(min max);
58 $DEBUG = 0 unless defined $DEBUG;
61 %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
62 qw(isstrongseverity bug_presence split_status_fields),
64 read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
65 qw(lock_read_all_merged_bugs),
67 write => [qw(writebug makestatus unlockwritebug)],
69 versions => [qw(addfoundversions addfixedversions),
70 qw(removefoundversions removefixedversions)
72 hook => [qw(bughook bughook_archive)],
73 indexdb => [qw(generate_index_db_line)],
74 fields => [qw(%fields)],
77 Exporter::export_ok_tags(keys %EXPORT_TAGS);
78 $EXPORT_TAGS{all} = [@EXPORT_OK];
84 readbug($bug_num,$location)
87 Reads a summary file from the archive given a bug number and a bug
88 location. Valid locations are those understood by L</getbugcomponent>
92 # these probably shouldn't be imported by most people, but
93 # Debbugs::Control needs them, so they're now exportable
94 our %fields = (originator => 'submitter',
97 msgid => 'message-id',
98 'package' => 'package',
101 forwarded => 'forwarded-to',
102 mergedwith => 'merged-with',
103 severity => 'severity',
105 found_versions => 'found-in',
106 found_date => 'found-date',
107 fixed_versions => 'fixed-in',
108 fixed_date => 'fixed-date',
110 blockedby => 'blocked-by',
111 unarchived => 'unarchived',
112 summary => 'summary',
113 outlook => 'outlook',
114 affects => 'affects',
118 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
119 my @rfc1522_fields = qw(originator subject done forwarded owner);
122 return read_bug(bug => $_[0],
123 (@_ > 1)?(location => $_[1]):()
129 read_bug(bug => $bug_num,
130 location => 'archive',
132 read_bug(summary => 'path/to/bugnum.summary');
135 A more complete function than readbug; it enables you to pass a full
136 path to the summary file instead of the bug number and/or location.
142 =item bug -- the bug number
144 =item location -- optional location which is passed to getbugcomponent
146 =item summary -- complete path to the .summary file which will be read
148 =item lock -- whether to obtain a lock for the bug to prevent
149 something modifying it while the bug has been read. You B<must> call
150 C<unfilelock();> if something not undef is returned from read_bug.
152 =item locks -- hashref of already obtained locks; incremented as new
153 locks are needed, and decremented as locks are released on particular
158 One of C<bug> or C<summary> must be passed. This function will return
159 undef on failure, and will die if improper arguments are passed.
167 my %param = validate_with(params => \@_,
168 spec => {bug => {type => SCALAR,
172 # negative bugnumbers
175 location => {type => SCALAR|UNDEF,
178 summary => {type => SCALAR,
181 lock => {type => BOOLEAN,
184 locks => {type => HASHREF,
189 die "One of bug or summary must be passed to read_bug"
190 if not exists $param{bug} and not exists $param{summary};
194 if (not defined $param{summary}) {
196 ($lref,$location) = @param{qw(bug location)};
197 if (not defined $location) {
198 $location = getbuglocation($lref,'summary');
199 return undef if not defined $location;
201 $status = getbugcomponent($lref, 'summary', $location);
202 $log = getbugcomponent($lref, 'log' , $location);
203 return undef unless defined $status;
204 return undef if not -e $status;
207 $status = $param{summary};
209 $log =~ s/\.summary$/.log/;
210 ($location) = $status =~ m/(db-h|db|archive)/;
213 filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
215 my $status_fh = IO::File->new($status, 'r');
216 if (not defined $status_fh) {
217 warn "Unable to open $status for reading: $!";
219 unfilelock(exists $param{locks}?$param{locks}:());
223 binmode($status_fh,':encoding(UTF-8)');
230 while (<$status_fh>) {
233 $version = $1 if /^Format-Version: ([0-9]+)/i;
236 # Version 3 is the latest format version currently supported.
238 warn "Unsupported status version '$version'";
240 unfilelock(exists $param{locks}?$param{locks}:());
245 my %namemap = reverse %fields;
246 for my $line (@lines) {
247 if ($line =~ /(\S+?): (.*)/) {
248 my ($name, $value) = (lc $1, $2);
249 # this is a bit of a hack; we should never, ever have \r
250 # or \n in the fields of status. Kill them off here.
251 # [Eventually, this should be superfluous.]
252 $value =~ s/[\r\n]//g;
253 $data{$namemap{$name}} = $value if exists $namemap{$name};
256 for my $field (keys %fields) {
257 $data{$field} = '' unless exists $data{$field};
260 for my $field (@rfc1522_fields) {
261 $data{$field} = decode_rfc1522($data{$field});
264 $data{severity} = $config{default_severity} if $data{severity} eq '';
265 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
266 $data{$field} = [split ' ', $data{$field}];
268 for my $field (qw(found fixed)) {
269 # create the found/fixed hashes which indicate when a
270 # particular version was marked found or marked fixed.
271 @{$data{$field}}{@{$data{"${field}_versions"}}} =
272 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
273 @{$data{"${field}_date"}});
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 = 3 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)};
612 %newdata = encode_utf8_structure(%newdata);
615 for my $field (@rfc1522_fields) {
616 $newdata{$field} = encode_rfc1522($newdata{$field});
620 # this is a bit of a hack; we should never, ever have \r or \n in
621 # the fields of status. Kill them off here. [Eventually, this
622 # should be superfluous.]
623 for my $field (keys %newdata) {
624 $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
628 for my $field (@v1fieldorder) {
629 if (exists $newdata{$field} and defined $newdata{$field}) {
630 $contents .= "$newdata{$field}\n";
635 } elsif ($version == 2 or $version == 3) {
636 # Version 2 or 3. Add a file format version number for the sake of
637 # further extensibility in the future.
638 $contents .= "Format-Version: $version\n";
639 for my $field (keys %fields) {
640 if (exists $newdata{$field} and defined $newdata{$field}
641 and $newdata{$field} ne '') {
642 # Output field names in proper case, e.g. 'Merged-With'.
643 my $properfield = $fields{$field};
644 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
645 my $data = $newdata{$field};
646 $contents .= "$properfield: $data\n";
655 writebug($bug_num,$status,$location,$minversion,$disablebughook)
657 Writes the bug status and summary files out.
659 Skips writting out a status file if minversion is 2
661 Does not call bughook if disablebughook is true.
666 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
669 my %outputs = (1 => 'status', 3 => 'summary');
670 for my $version (keys %outputs) {
671 next if defined $minversion and $version < $minversion;
672 my $status = getbugcomponent($ref, $outputs{$version}, $location);
673 die "can't find location for $ref" unless defined $status;
676 open $sfh,">","$status.new" or
677 die "opening $status.new: $!";
680 open $sfh,">","$status.new" or
681 die "opening $status.new: $!";
683 print {$sfh} makestatus($data, $version) or
684 die "writing $status.new: $!";
685 close($sfh) or die "closing $status.new: $!";
691 rename("$status.new",$status) || die "installing new $status: $!";
694 # $disablebughook is a bit of a hack to let format migration scripts use
695 # this function rather than having to duplicate it themselves.
696 &bughook($change,$ref,$data) unless $disablebughook;
699 =head2 unlockwritebug
701 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
703 Writes a bug, then calls unfilelock; see writebug for what these
715 The following functions are exported with the :versions tag
717 =head2 addfoundversions
719 addfoundversions($status,$package,$version,$isbinary);
721 All use of this should be phased out in favor of Debbugs::Control::fixed/found
726 sub addfoundversions {
730 my $isbinary = shift;
731 return unless defined $version;
732 undef $package if $package =~ m[(?:\s|/)];
733 my $source = $package;
734 if ($package =~ s/^src://) {
739 if (defined $package and $isbinary) {
740 my @srcinfo = binary_to_source(binary => $package,
741 version => $version);
743 # We know the source package(s). Use a fully-qualified version.
744 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
747 # Otherwise, an unqualified version will have to do.
751 # Strip off various kinds of brain-damage.
753 $version =~ s/ *\(.*\)//;
754 $version =~ s/ +[A-Za-z].*//;
756 foreach my $ver (split /[,\s]+/, $version) {
757 my $sver = defined($source) ? "$source/$ver" : '';
758 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
759 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
761 @{$data->{fixed_versions}} =
762 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
766 =head2 removefoundversions
768 removefoundversions($data,$package,$versiontoremove)
770 Removes found versions from $data
772 If a version is fully qualified (contains /) only versions matching
773 exactly are removed. Otherwise, all versions matching the version
776 Currently $package and $isbinary are entirely ignored, but accepted
777 for backwards compatibilty.
781 sub removefoundversions {
785 my $isbinary = shift;
786 return unless defined $version;
788 foreach my $ver (split /[,\s]+/, $version) {
790 # fully qualified version
791 @{$data->{found_versions}} =
793 @{$data->{found_versions}};
796 # non qualified version; delete all matchers
797 @{$data->{found_versions}} =
798 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
799 @{$data->{found_versions}};
805 sub addfixedversions {
809 my $isbinary = shift;
810 return unless defined $version;
811 undef $package if defined $package and $package =~ m[(?:\s|/)];
812 my $source = $package;
814 if (defined $package and $isbinary) {
815 my @srcinfo = binary_to_source(binary => $package,
816 version => $version);
818 # We know the source package(s). Use a fully-qualified version.
819 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
822 # Otherwise, an unqualified version will have to do.
826 # Strip off various kinds of brain-damage.
828 $version =~ s/ *\(.*\)//;
829 $version =~ s/ +[A-Za-z].*//;
831 foreach my $ver (split /[,\s]+/, $version) {
832 my $sver = defined($source) ? "$source/$ver" : '';
833 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
834 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
836 @{$data->{found_versions}} =
837 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
841 sub removefixedversions {
845 my $isbinary = shift;
846 return unless defined $version;
848 foreach my $ver (split /[,\s]+/, $version) {
850 # fully qualified version
851 @{$data->{fixed_versions}} =
853 @{$data->{fixed_versions}};
856 # non qualified version; delete all matchers
857 @{$data->{fixed_versions}} =
858 grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
859 @{$data->{fixed_versions}};
870 Split a package string from the status file into a list of package names.
876 return unless defined $pkgs;
877 return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
881 =head2 bug_archiveable
883 bug_archiveable(bug => $bug_num);
889 =item bug -- bug number (required)
891 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
893 =item version -- Debbugs::Version information (optional)
895 =item days_until -- return days until the bug can be archived
899 Returns 1 if the bug can be archived
900 Returns 0 if the bug cannot be archived
902 If days_until is true, returns the number of days until the bug can be
903 archived, -1 if it cannot be archived. 0 means that the bug can be
904 archived the next time the archiver runs.
906 Returns undef on failure.
910 # This will eventually need to be fixed before we start using mod_perl
911 our $version_cache = {};
913 my %param = validate_with(params => \@_,
914 spec => {bug => {type => SCALAR,
917 status => {type => HASHREF,
920 days_until => {type => BOOLEAN,
923 ignore_time => {type => BOOLEAN,
928 # This is what we return if the bug cannot be archived.
929 my $cannot_archive = $param{days_until}?-1:0;
930 # read the status information
931 my $status = $param{status};
932 if (not exists $param{status} or not defined $status) {
933 $status = read_bug(bug=>$param{bug});
934 if (not defined $status) {
935 print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
939 # Bugs can be archived if they are
941 if (not defined $status->{done} or not length $status->{done}) {
942 print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
943 return $cannot_archive
945 # Check to make sure that the bug has none of the unremovable tags set
946 if (@{$config{removal_unremovable_tags}}) {
947 for my $tag (split ' ', ($status->{keywords}||'')) {
948 if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
949 print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
950 return $cannot_archive;
955 # If we just are checking if the bug can be archived, we'll not even bother
956 # checking the versioning information if the bug has been -done for less than 28 days.
957 my $log_file = getbugcomponent($param{bug},'log');
958 if (not defined $log_file) {
959 print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
960 return $cannot_archive;
962 my $max_log_age = max(map {$config{remove_age} - -M $_}
963 $log_file, map {my $log = getbugcomponent($_,'log');
964 defined $log ? ($log) : ();
966 split / /, $status->{mergedwith}
968 if (not $param{days_until} and not $param{ignore_time}
971 print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
972 return $cannot_archive;
974 # At this point, we have to get the versioning information for this bug.
975 # We examine the set of distribution tags. If a bug has no distribution
976 # tags set, we assume a default set, otherwise we use the tags the bug
979 # In cases where we are assuming a default set, if the severity
980 # is strong, we use the strong severity default; otherwise, we
981 # use the normal default.
983 # There must be fixed_versions for us to look at the versioning
985 my $min_fixed_time = time;
986 my $min_archive_days = 0;
987 if (@{$status->{fixed_versions}}) {
989 @dist_tags{@{$config{removal_distribution_tags}}} =
990 (1) x @{$config{removal_distribution_tags}};
992 for my $tag (split ' ', ($status->{keywords}||'')) {
993 next unless exists $config{distribution_aliases}{$tag};
994 next unless $dist_tags{$config{distribution_aliases}{$tag}};
995 $dists{$config{distribution_aliases}{$tag}} = 1;
997 if (not keys %dists) {
998 if (isstrongseverity($status->{severity})) {
999 @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1000 (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1003 @dists{@{$config{removal_default_distribution_tags}}} =
1004 (1) x @{$config{removal_default_distribution_tags}};
1007 my %source_versions;
1008 my @sourceversions = get_versions(package => $status->{package},
1009 dist => [keys %dists],
1012 @source_versions{@sourceversions} = (1) x @sourceversions;
1013 # If the bug has not been fixed in the versions actually
1014 # distributed, then it cannot be archived.
1015 if ('found' eq max_buggy(bug => $param{bug},
1016 sourceversions => [keys %source_versions],
1017 found => $status->{found_versions},
1018 fixed => $status->{fixed_versions},
1019 version_cache => $version_cache,
1020 package => $status->{package},
1022 print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1023 return $cannot_archive;
1025 # Since the bug has at least been fixed in the architectures
1026 # that matters, we check to see how long it has been fixed.
1028 # If $param{ignore_time}, then we should ignore time.
1029 if ($param{ignore_time}) {
1030 return $param{days_until}?0:1;
1033 # To do this, we order the times from most recent to oldest;
1034 # when we come to the first found version, we stop.
1035 # If we run out of versions, we only report the time of the
1037 my %time_versions = get_versions(package => $status->{package},
1038 dist => [keys %dists],
1042 for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1043 my $buggy = buggy(bug => $param{bug},
1044 version => $version,
1045 found => $status->{found_versions},
1046 fixed => $status->{fixed_versions},
1047 version_cache => $version_cache,
1048 package => $status->{package},
1050 last if $buggy eq 'found';
1051 $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1053 $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1054 # if there are no versions in the archive at all, then
1055 # we can archive if enough days have passed
1058 # If $param{ignore_time}, then we should ignore time.
1059 if ($param{ignore_time}) {
1060 return $param{days_until}?0:1;
1062 # 6. at least 28 days have passed since the last action has occured or the bug was closed
1063 my $age = ceil($max_log_age);
1064 if ($age > 0 or $min_archive_days > 0) {
1065 print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1066 return $param{days_until}?max($age,$min_archive_days):0;
1069 return $param{days_until}?0:1;
1074 =head2 get_bug_status
1076 my $status = get_bug_status(bug => $nnn);
1078 my $status = get_bug_status($bug_num)
1084 =item bug -- scalar bug number
1086 =item status -- optional hashref of bug status as returned by readbug
1087 (can be passed to avoid rereading the bug information)
1089 =item bug_index -- optional tied index of bug status infomration;
1090 currently not correctly implemented.
1092 =item version -- optional version(s) to check package status at
1094 =item dist -- optional distribution(s) to check package status at
1096 =item arch -- optional architecture(s) to check package status at
1098 =item bugusertags -- optional hashref of bugusertags
1100 =item sourceversion -- optional arrayref of source/version; overrides
1101 dist, arch, and version. [The entries in this array must be in the
1102 "source/version" format.] Eventually this can be used to for caching.
1104 =item indicatesource -- if true, indicate which source packages this
1105 bug could belong to (or does belong to in the case of bugs assigned to
1106 a source package). Defaults to true.
1110 Note: Currently the version information is cached; this needs to be
1111 changed before using this function in long lived programs.
1115 Currently returns a hashref of status with the following keys.
1119 =item id -- bug number
1121 =item bug_num -- duplicate of id
1123 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1125 =item tags -- duplicate of keywords
1127 =item package -- name of package that the bug is assigned to
1129 =item severity -- severity of the bug
1131 =item pending -- pending state of the bug; one of following possible
1132 values; values listed later have precedence if multiple conditions are
1137 =item pending -- default state
1139 =item forwarded -- bug has been forwarded
1141 =item pending-fixed -- bug is tagged pending
1143 =item fixed -- bug is tagged fixed
1145 =item absent -- bug does not apply to this distribution/architecture
1147 =item done -- bug is resolved in this distribution/architecture
1151 =item location -- db-h or archive; the location in the filesystem
1153 =item subject -- title of the bug
1155 =item last_modified -- epoch that the bug was last modified
1157 =item date -- epoch that the bug was filed
1159 =item originator -- bug reporter
1161 =item log_modified -- epoch that the log file was last modified
1163 =item msgid -- Message id of the original bug report
1168 Other key/value pairs are returned but are not currently documented here.
1172 sub get_bug_status {
1176 my %param = validate_with(params => \@_,
1177 spec => {bug => {type => SCALAR,
1180 status => {type => HASHREF,
1183 bug_index => {type => OBJECT,
1186 version => {type => SCALAR|ARRAYREF,
1189 dist => {type => SCALAR|ARRAYREF,
1192 arch => {type => SCALAR|ARRAYREF,
1195 bugusertags => {type => HASHREF,
1198 sourceversions => {type => ARRAYREF,
1201 indicatesource => {type => BOOLEAN,
1208 if (defined $param{bug_index} and
1209 exists $param{bug_index}{$param{bug}}) {
1210 %status = %{ $param{bug_index}{$param{bug}} };
1211 $status{pending} = $status{ status };
1212 $status{id} = $param{bug};
1215 if (defined $param{status}) {
1216 %status = %{$param{status}};
1219 my $location = getbuglocation($param{bug}, 'summary');
1220 return {} if not defined $location or not length $location;
1221 %status = %{ readbug( $param{bug}, $location ) };
1223 $status{id} = $param{bug};
1225 if (defined $param{bugusertags}{$param{bug}}) {
1226 $status{keywords} = "" unless defined $status{keywords};
1227 $status{keywords} .= " " unless $status{keywords} eq "";
1228 $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1230 $status{tags} = $status{keywords};
1231 my %tags = map { $_ => 1 } split ' ', $status{tags};
1233 $status{package} = '' if not defined $status{package};
1234 $status{"package"} =~ s/\s*$//;
1236 $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1240 $status{"package"} = 'unknown' if ($status{"package"} eq '');
1241 $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1243 $status{"pending"} = 'pending';
1244 $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
1245 $status{"pending"} = 'pending-fixed' if ($tags{pending});
1246 $status{"pending"} = 'fixed' if ($tags{fixed});
1249 my $presence = bug_presence(status => \%status,
1250 map{(exists $param{$_})?($_,$param{$_}):()}
1251 qw(bug sourceversions arch dist version found fixed package)
1253 if (defined $presence) {
1254 if ($presence eq 'fixed') {
1255 $status{pending} = 'done';
1257 elsif ($presence eq 'absent') {
1258 $status{pending} = 'absent';
1266 my $precence = bug_presence(bug => nnn,
1270 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1271 is found, absent, fixed, or no information is available in the
1272 distribution (dist) and/or architecture (arch) specified.
1279 =item bug -- scalar bug number
1281 =item status -- optional hashref of bug status as returned by readbug
1282 (can be passed to avoid rereading the bug information)
1284 =item bug_index -- optional tied index of bug status infomration;
1285 currently not correctly implemented.
1287 =item version -- optional version to check package status at
1289 =item dist -- optional distribution to check package status at
1291 =item arch -- optional architecture to check package status at
1293 =item sourceversion -- optional arrayref of source/version; overrides
1294 dist, arch, and version. [The entries in this array must be in the
1295 "source/version" format.] Eventually this can be used to for caching.
1302 my %param = validate_with(params => \@_,
1303 spec => {bug => {type => SCALAR,
1306 status => {type => HASHREF,
1309 version => {type => SCALAR|ARRAYREF,
1312 dist => {type => SCALAR|ARRAYREF,
1315 arch => {type => SCALAR|ARRAYREF,
1318 sourceversions => {type => ARRAYREF,
1324 if (defined $param{status}) {
1325 %status = %{$param{status}};
1328 my $location = getbuglocation($param{bug}, 'summary');
1329 return {} if not length $location;
1330 %status = %{ readbug( $param{bug}, $location ) };
1334 my $pseudo_desc = getpseudodesc();
1335 if (not exists $param{sourceversions}) {
1337 # pseudopackages do not have source versions by definition.
1338 if (exists $pseudo_desc->{$status{package}}) {
1341 elsif (defined $param{version}) {
1342 foreach my $arch (make_list($param{arch})) {
1343 for my $package (split /\s*,\s*/, $status{package}) {
1344 my @temp = makesourceversions($package,
1346 make_list($param{version})
1348 @sourceversions{@temp} = (1) x @temp;
1351 } elsif (defined $param{dist}) {
1352 my %affects_distribution_tags;
1353 @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1354 (1) x @{$config{affects_distribution_tags}};
1355 my $some_distributions_disallowed = 0;
1356 my %allowed_distributions;
1357 for my $tag (split ' ', ($status{keywords}||'')) {
1358 if (exists $config{distribution_aliases}{$tag} and
1359 exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1360 $some_distributions_disallowed = 1;
1361 $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1363 elsif (exists $affects_distribution_tags{$tag}) {
1364 $some_distributions_disallowed = 1;
1365 $allowed_distributions{$tag} = 1;
1368 my @archs = make_list(exists $param{arch}?$param{arch}:());
1369 GET_SOURCE_VERSIONS:
1370 foreach my $arch (@archs) {
1371 for my $package (split /\s*,\s*/, $status{package}) {
1374 if ($package =~ /^src:(.+)$/) {
1378 foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1379 # if some distributions are disallowed,
1380 # and this isn't an allowed
1381 # distribution, then we ignore this
1382 # distribution for the purposees of
1384 if ($some_distributions_disallowed and
1385 not exists $allowed_distributions{$dist}) {
1388 push @versions, get_versions(package => $package,
1390 ($source?(arch => 'source'):
1391 (defined $arch?(arch => $arch):())),
1394 next unless @versions;
1395 my @temp = make_source_versions(package => $package,
1397 versions => \@versions,
1399 @sourceversions{@temp} = (1) x @temp;
1402 # this should really be split out into a subroutine,
1403 # but it'd touch so many things currently, that we fake
1404 # it; it's needed to properly handle bugs which are
1405 # erroneously assigned to the binary package, and we'll
1406 # probably have it go away eventually.
1407 if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1409 goto GET_SOURCE_VERSIONS;
1413 # TODO: This should probably be handled further out for efficiency and
1414 # for more ease of distinguishing between pkg= and src= queries.
1415 # DLA: src= queries should just pass arch=source, and they'll be happy.
1416 @sourceversions = keys %sourceversions;
1419 @sourceversions = @{$param{sourceversions}};
1421 my $maxbuggy = 'undef';
1422 if (@sourceversions) {
1423 $maxbuggy = max_buggy(bug => $param{bug},
1424 sourceversions => \@sourceversions,
1425 found => $status{found_versions},
1426 fixed => $status{fixed_versions},
1427 package => $status{package},
1428 version_cache => $version_cache,
1431 elsif (defined $param{dist} and
1432 not exists $pseudo_desc->{$status{package}}) {
1435 if (length($status{done}) and
1436 (not @sourceversions or not @{$status{fixed_versions}})) {
1451 =item bug -- scalar bug number
1453 =item sourceversion -- optional arrayref of source/version; overrides
1454 dist, arch, and version. [The entries in this array must be in the
1455 "source/version" format.] Eventually this can be used to for caching.
1459 Note: Currently the version information is cached; this needs to be
1460 changed before using this function in long lived programs.
1465 my %param = validate_with(params => \@_,
1466 spec => {bug => {type => SCALAR,
1469 sourceversions => {type => ARRAYREF,
1472 found => {type => ARRAYREF,
1475 fixed => {type => ARRAYREF,
1478 package => {type => SCALAR,
1480 version_cache => {type => HASHREF,
1485 # Resolve bugginess states (we might be looking at multiple
1486 # architectures, say). Found wins, then fixed, then absent.
1487 my $maxbuggy = 'absent';
1488 for my $package (split /\s*,\s*/, $param{package}) {
1489 for my $version (@{$param{sourceversions}}) {
1490 my $buggy = buggy(bug => $param{bug},
1491 version => $version,
1492 found => $param{found},
1493 fixed => $param{fixed},
1494 version_cache => $param{version_cache},
1495 package => $package,
1497 if ($buggy eq 'found') {
1499 } elsif ($buggy eq 'fixed') {
1500 $maxbuggy = 'fixed';
1517 Returns the output of Debbugs::Versions::buggy for a particular
1518 package, version and found/fixed set. Automatically turns found, fixed
1519 and version into source/version strings.
1521 Caching can be had by using the version_cache, but no attempt to check
1522 to see if the on disk information is more recent than the cache is
1523 made. [This will need to be fixed for long-lived processes.]
1528 my %param = validate_with(params => \@_,
1529 spec => {bug => {type => SCALAR,
1532 found => {type => ARRAYREF,
1535 fixed => {type => ARRAYREF,
1538 version_cache => {type => HASHREF,
1541 package => {type => SCALAR,
1543 version => {type => SCALAR,
1547 my @found = @{$param{found}};
1548 my @fixed = @{$param{fixed}};
1549 if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1550 # We have non-source version versions
1551 @found = makesourceversions($param{package},undef,
1554 @fixed = makesourceversions($param{package},undef,
1558 if ($param{version} !~ m{/}) {
1559 my ($version) = makesourceversions($param{package},undef,
1562 $param{version} = $version if defined $version;
1564 # Figure out which source packages we need
1566 @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1567 @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1568 @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1569 $param{version} =~ m{/};
1571 if (not defined $param{version_cache} or
1572 not exists $param{version_cache}{join(',',sort keys %sources)}) {
1573 $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1574 foreach my $source (keys %sources) {
1575 my $srchash = substr $source, 0, 1;
1576 my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1577 if (not defined $version_fh) {
1578 # We only want to warn if it's a package which actually has a maintainer
1579 my $maints = getmaintainers();
1580 next if not exists $maints->{$source};
1581 warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1584 $version->load($version_fh);
1586 if (defined $param{version_cache}) {
1587 $param{version_cache}{join(',',sort keys %sources)} = $version;
1591 $version = $param{version_cache}{join(',',sort keys %sources)};
1593 return $version->buggy($param{version},\@found,\@fixed);
1596 sub isstrongseverity {
1597 my $severity = shift;
1598 $severity = $config{default_severity} if
1599 not defined $severity or $severity eq '';
1600 return grep { $_ eq $severity } @{$config{strong_severities}};
1605 =head2 generate_index_db_line
1607 my $data = read_bug(bug => $bug,
1608 location => $initialdir);
1609 # generate_index_db_line hasn't been written yet at all.
1610 my $line = generate_index_db_line($data);
1612 Returns a line for a bug suitable to be written out to index.db.
1616 sub generate_index_db_line {
1619 # just in case someone has given us a split out data
1620 $data = join_status_fields($data);
1622 my $whendone = "open";
1623 my $severity = $config{default_severity};
1624 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1625 $pkglist =~ s/^,+//;
1626 $pkglist =~ s/,+$//;
1627 $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1628 $whendone = "done" if defined $data->{done} and length $data->{done};
1629 $severity = $data->{severity} if length $data->{severity};
1631 return sprintf "%s %d %d %s [%s] %s %s\n",
1632 $pkglist, $data->{bug_num}, $data->{date}, $whendone,
1633 $data->{originator}, $severity, $data->{keywords};
1638 =head1 PRIVATE FUNCTIONS
1642 sub update_realtime {
1643 my ($file, %bugs) = @_;
1645 # update realtime index.db
1647 return () unless keys %bugs;
1648 my $idx_old = IO::File->new($file,'r')
1649 or die "Couldn't open ${file}: $!";
1650 my $idx_new = IO::File->new($file.'.new','w')
1651 or die "Couldn't open ${file}.new: $!";
1653 binmode($idx_old,':raw:utf8');
1654 binmode($idx_new,':raw:encoding(UTF-8)');
1655 my $min_bug = min(keys %bugs);
1659 while($line = <$idx_old>) {
1660 @line = split /\s/, $line;
1661 # Two cases; replacing existing line or adding new line
1662 if (exists $bugs{$line[1]}) {
1663 my $new = $bugs{$line[1]};
1664 delete $bugs{$line[1]};
1665 $min_bug = min(keys %bugs);
1666 if ($new eq "NOCHANGE") {
1667 print {$idx_new} $line;
1668 $changed_bugs{$line[1]} = $line;
1669 } elsif ($new eq "REMOVE") {
1670 $changed_bugs{$line[1]} = $line;
1672 print {$idx_new} $new;
1673 $changed_bugs{$line[1]} = $line;
1677 while ($line[1] > $min_bug) {
1678 print {$idx_new} $bugs{$min_bug};
1679 delete $bugs{$min_bug};
1680 last unless keys %bugs;
1681 $min_bug = min(keys %bugs);
1683 print {$idx_new} $line;
1685 last unless keys %bugs;
1687 print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1689 print {$idx_new} <$idx_old>;
1694 rename("$file.new", $file);
1696 return %changed_bugs;
1699 sub bughook_archive {
1701 filelock("$config{spool_dir}/debbugs.trace.lock");
1702 appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1703 my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1704 map{($_,'REMOVE')} @refs);
1705 update_realtime("$config{spool_dir}/index.archive.realtime",
1711 my ( $type, %bugs_temp ) = @_;
1712 filelock("$config{spool_dir}/debbugs.trace.lock");
1715 for my $bug (keys %bugs_temp) {
1716 my $data = $bugs_temp{$bug};
1717 appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1719 $bugs{$bug} = generate_index_db_line($data);
1721 update_realtime("$config{spool_dir}/index.db.realtime", %bugs);