X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;ds=sidebyside;f=Debbugs%2FStatus.pm;h=e880783ca87493680b3c751e32cd06df7cf54526;hb=7794f8e5eeb42a5b99caa0c50126eac150b3750e;hp=5fb5413dcdb3fb1a1e3323ec29a9b45d77da6a4c;hpb=580822d029b7914604e00b23974bd1baa8410bed;p=debbugs.git diff --git a/Debbugs/Status.pm b/Debbugs/Status.pm index 5fb5413..e880783 100644 --- a/Debbugs/Status.pm +++ b/Debbugs/Status.pm @@ -5,7 +5,7 @@ # # [Other people have contributed to this file; their copyrights should # go here too.] -# Copyright 2007 by Don Armstrong . +# Copyright 2007-9 by Don Armstrong . package Debbugs::Status; @@ -32,20 +32,25 @@ status of a particular bug use warnings; use strict; + use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); use base qw(Exporter); use Params::Validate qw(validate_with :types); -use Debbugs::Common qw(:util :lock :quit :misc); +use Debbugs::Common qw(:util :lock :quit :misc :utf8); use Debbugs::Config qw(:config); use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); -use Debbugs::Packages qw(makesourceversions getversions get_versions binarytosource); +use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source); use Debbugs::Versions; use Debbugs::Versions::Dpkg; use POSIX qw(ceil); +use File::Copy qw(copy); +use Encode qw(decode encode is_utf8); +use Storable qw(dclone); use List::Util qw(min max); +use Carp qw(croak); BEGIN{ $VERSION = 1.00; @@ -53,17 +58,21 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable), - qw(isstrongseverity bug_presence), + qw(isstrongseverity bug_presence split_status_fields), + ], + read => [qw(readbug read_bug lockreadbug lockreadbugmerge), + qw(lock_read_all_merged_bugs), ], - read => [qw(readbug read_bug lockreadbug lockreadbugmerge)], write => [qw(writebug makestatus unlockwritebug)], + new => [qw(new_bug)], versions => [qw(addfoundversions addfixedversions), qw(removefoundversions removefixedversions) ], hook => [qw(bughook bughook_archive)], + fields => [qw(%fields)], ); @EXPORT_OK = (); - Exporter::export_ok_tags(qw(status read write versions hook)); + Exporter::export_ok_tags(keys %EXPORT_TAGS); $EXPORT_TAGS{all} = [@EXPORT_OK]; } @@ -78,8 +87,9 @@ location. Valid locations are those understood by L =cut - -my %fields = (originator => 'submitter', +# these probably shouldn't be imported by most people, but +# Debbugs::Control needs them, so they're now exportable +our %fields = (originator => 'submitter', date => 'date', subject => 'subject', msgid => 'message-id', @@ -97,8 +107,11 @@ my %fields = (originator => 'submitter', blocks => 'blocks', blockedby => 'blocked-by', unarchived => 'unarchived', + summary => 'summary', + affects => 'affects', ); + # Fields which need to be RFC1522-decoded in format versions earlier than 3. my @rfc1522_fields = qw(originator subject done forwarded owner); @@ -129,6 +142,14 @@ path to the summary file instead of the bug number and/or location. =item summary -- complete path to the .summary file which will be read +=item lock -- whether to obtain a lock for the bug to prevent +something modifying it while the bug has been read. You B call +C if something not undef is returned from read_bug. + +=item locks -- hashref of already obtained locks; incremented as new +locks are needed, and decremented as locks are released on particular +files. + =back One of C or C must be passed. This function will return @@ -154,25 +175,48 @@ sub read_bug{ summary => {type => SCALAR, optional => 1, }, + lock => {type => BOOLEAN, + optional => 1, + }, + locks => {type => HASHREF, + optional => 1, + }, }, ); die "One of bug or summary must be passed to read_bug" if not exists $param{bug} and not exists $param{summary}; my $status; + my $log; + my $location; if (not defined $param{summary}) { - my ($lref, $location) = @param{qw(bug location)}; + my $lref; + ($lref,$location) = @param{qw(bug location)}; if (not defined $location) { $location = getbuglocation($lref,'summary'); return undef if not defined $location; } $status = getbugcomponent($lref, 'summary', $location); + $log = getbugcomponent($lref, 'log' , $location); return undef unless defined $status; + return undef if not -e $status; } else { $status = $param{summary}; + $log = $status; + $log =~ s/\.summary$/.log/; + ($location) = $status =~ m/(db-h|db|archive)/; + } + if ($param{lock}) { + filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:()); + } + my $status_fh = IO::File->new($status, 'r'); + if (not defined $status_fh) { + warn "Unable to open $status for reading: $!"; + if ($param{lock}) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + return undef; } - my $status_fh = new IO::File $status, 'r' or - warn "Unable to open $status for reading: $!" and return undef; my %data; my @lines; @@ -186,19 +230,48 @@ sub read_bug{ } # Version 3 is the latest format version currently supported. - return undef if $version > 3; + if ($version > 3) { + warn "Unsupported status version '$version'"; + if ($param{lock}) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + return undef; + } my %namemap = reverse %fields; + for my $field (keys %fields) { + $data{$field} = '' unless exists $data{$field}; + } + if ($version < 3) { + for my $field (@rfc1522_fields) { + $data{$field} = decode_rfc1522($data{$field}); + } + } for my $line (@lines) { + my @encodings_to_try = qw(utf8 iso8859-1); + if ($version >= 3) { + @encodings_to_try = qw(utf8); + } + for (@encodings_to_try) { + last if is_utf8($line); + my $temp; + eval { + $temp = decode("$_",$line,Encode::FB_CROAK); + }; + if (not $@) { # only update the line if there are no errors. + $line = $temp; + last; + } + } if ($line =~ /(\S+?): (.*)/) { my ($name, $value) = (lc $1, $2); - $data{$namemap{$name}} = $value if exists $namemap{$name}; + # this is a bit of a hack; we should never, ever have \r + # or \n in the fields of status. Kill them off here. + # [Eventually, this should be superfluous.] + $value =~ s/[\r\n]//g; + $data{$namemap{$name}} = $value if exists $namemap{$name}; } } - for my $field (keys %fields) { - $data{$field} = '' unless exists $data{$field}; - } - $data{severity} = $config{default_severity} if $data{severity} eq ''; for my $field (qw(found_versions fixed_versions found_date fixed_date)) { $data{$field} = [split ' ', $data{$field}]; @@ -211,15 +284,120 @@ sub read_bug{ @{$data{"${field}_date"}}); } - if ($version < 3) { - for my $field (@rfc1522_fields) { - $data{$field} = decode_rfc1522($data{$field}); + my $status_modified = (stat($status))[9]; + # Add log last modified time + $data{log_modified} = (stat($log))[9]; + $data{last_modified} = max($status_modified,$data{log_modified}); + $data{location} = $location; + $data{archived} = (defined($location) and ($location eq 'archive'))?1:0; + $data{bug_num} = $param{bug}; + + return \%data; +} + +=head2 split_status_fields + + my @data = split_status_fields(@data); + +Splits splittable status fields (like package, tags, blocks, +blockedby, etc.) into arrayrefs (use make_list on these). Keeps the +passed @data intact using dclone. + +In scalar context, returns only the first element of @data. + +=cut + +our $ditch_empty = sub{ + my @t = @_; + my $splitter = shift @t; + return grep {length $_} map {split $splitter} @t; +}; + +my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)}; +my %split_fields = + (package => \&splitpackages, + affects => \&splitpackages, + blocks => $ditch_empty_space, + blockedby => $ditch_empty_space, + # this isn't strictly correct, but we'll split both of them for + # the time being until we ditch all use of keywords everywhere + # from the code + keywords => $ditch_empty_space, + tags => $ditch_empty_space, + found_versions => $ditch_empty_space, + fixed_versions => $ditch_empty_space, + mergedwith => $ditch_empty_space, + ); + +sub split_status_fields { + my @data = @{dclone(\@_)}; + for my $data (@data) { + next if not defined $data; + croak "Passed an element which is not a hashref to split_status_field".ref($data) if + not (ref($data) and ref($data) eq 'HASH'); + for my $field (keys %{$data}) { + next unless defined $data->{$field}; + if (exists $split_fields{$field}) { + next if ref($data->{$field}); + my @elements; + if (ref($split_fields{$field}) eq 'CODE') { + @elements = &{$split_fields{$field}}($data->{$field}); + } + elsif (not ref($split_fields{$field}) or + UNIVERSAL::isa($split_fields{$field},'Regex') + ) { + @elements = split $split_fields{$field}, $data->{$field}; + } + $data->{$field} = \@elements; + } } } + return wantarray?@data:$data[0]; +} - return \%data; +=head2 join_status_fields + + my @data = join_status_fields(@data); + +Handles joining the splitable status fields. (Basically, the inverse +of split_status_fields. + +Primarily called from makestatus, but may be useful for other +functions after calling split_status_fields (or for legacy functions +if we transition to split fields by default). + +=cut + +sub join_status_fields { + my %join_fields = + (package => ', ', + affects => ', ', + blocks => ' ', + blockedby => ' ', + tags => ' ', + found_versions => ' ', + fixed_versions => ' ', + found_date => ' ', + fixed_date => ' ', + mergedwith => ' ', + ); + my @data = @{dclone(\@_)}; + for my $data (@data) { + next if not defined $data; + croak "Passed an element which is not a hashref to split_status_field: ". + ref($data) + if ref($data) ne 'HASH'; + for my $field (keys %{$data}) { + next unless defined $data->{$field}; + next unless ref($data->{$field}) eq 'ARRAY'; + next unless exists $join_fields{$field}; + $data->{$field} = join($join_fields{$field},@{$data->{$field}}); + } + } + return wantarray?@data:$data[0]; } + =head2 lockreadbug lockreadbug($bug_num,$location) @@ -234,10 +412,7 @@ See readbug above for information on what this returns sub lockreadbug { my ($lref, $location) = @_; - &filelock("lock/$lref"); - my $data = read_bug(bug => $lref, location => $location); - &unfilelock unless defined $data; - return $data; + return read_bug(bug => $lref, location => $location, lock => 1); } =head2 lockreadbugmerge @@ -260,7 +435,7 @@ sub lockreadbugmerge { return (1,$data); } unfilelock(); - filelock('lock/merge'); + filelock("$config{spool_dir}/lock/merge"); $data = lockreadbug(@_); if (not defined $data) { unfilelock(); @@ -269,6 +444,147 @@ sub lockreadbugmerge { return (2,$data); } +=head2 lock_read_all_merged_bugs + + my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location); + +Performs a filelock, then reads the bug passed. If the bug is merged, +locks the merge lock, then reads and locks all of the other merged +bugs. Returns a list of the number of locks and the bug data for all +of the merged bugs. + +Will also return undef if any of the merged bugs failed to be read, +even if all of the others were read properly. + +=cut + +sub lock_read_all_merged_bugs { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + location => {type => SCALAR, + optional => 1, + }, + locks => {type => HASHREF, + optional => 1, + }, + }, + ); + my $locks = 0; + my @data = read_bug(bug => $param{bug}, + lock => 1, + exists $param{location} ? (location => $param{location}):(), + exists $param{locks} ? (locks => $param{locks}):(), + ); + if (not @data or not defined $data[0]) { + return ($locks,()); + } + $locks++; + if (not length $data[0]->{mergedwith}) { + return ($locks,@data); + } + unfilelock(exists $param{locks}?$param{locks}:()); + $locks--; + filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:()); + $locks++; + @data = read_bug(bug => $param{bug}, + lock => 1, + exists $param{location} ? (location => $param{location}):(), + exists $param{locks} ? (locks => $param{locks}):(), + ); + if (not @data or not defined $data[0]) { + unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above + $locks--; + return ($locks,()); + } + $locks++; + my @bugs = split / /, $data[0]->{mergedwith}; + push @bugs, $param{bug}; + for my $bug (@bugs) { + my $newdata = undef; + if ($bug != $param{bug}) { + $newdata = + read_bug(bug => $bug, + lock => 1, + exists $param{location} ? (location => $param{location}):(), + exists $param{locks} ? (locks => $param{locks}):(), + ); + if (not defined $newdata) { + for (1..$locks) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + $locks = 0; + warn "Unable to read bug: $bug while handling merged bug: $param{bug}"; + return ($locks,()); + } + $locks++; + push @data,$newdata; + # perform a sanity check to make sure that the merged bugs + # are all merged with eachother + my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } @bugs); + if ($newdata->{mergedwith} ne $expectmerge) { + for (1..$locks) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + die "Bug $param{bug} differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")"; + } + } + } + return ($locks,@data); +} + +=head2 new_bug + + my $new_bug_num = new_bug(copy => $data->{bug_num}); + +Creates a new bug and returns the new bug number upon success. + +Dies upon failures. + +=cut + +sub new_bug { + my %param = + validate_with(params => \@_, + spec => {copy => {type => SCALAR, + regex => qr/^\d+/, + optional => 1, + }, + }, + ); + filelock("nextnumber.lock"); + my $nn_fh = IO::File->new("nextnumber",'r') or + die "Unable to open nextnuber for reading: $!"; + local $\; + my $nn = <$nn_fh>; + ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$'; + close $nn_fh; + overwritefile("nextnumber", + ($nn+1)."\n"); + unfilelock(); + my $nn_hash = get_hashname($nn); + if ($param{copy}) { + my $c_hash = get_hashname($param{copy}); + for my $file (qw(log status summary report)) { + copy("db-h/$c_hash/$param{copy}.$file", + "db-h/$nn_hash/${nn}.$file") + } + } + else { + for my $file (qw(log status summary report)) { + overwritefile("db-h/$nn_hash/${nn}.$file", + ""); + } + } + + # this probably needs to be munged to do something more elegant +# &bughook('new', $clone, $data); + + return($nn); +} + + my @v1fieldorder = qw(originator date subject msgid package keywords done forwarded mergedwith severity); @@ -291,7 +607,7 @@ version. sub makestatus { my ($data,$version) = @_; - $version = 2 unless defined $version; + $version = 3 unless defined $version; my $contents = ''; @@ -302,10 +618,9 @@ sub makestatus { [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}]; } } + %newdata = %{join_status_fields(\%newdata)}; - for my $field (qw(found_versions fixed_versions found_date fixed_date)) { - $newdata{$field} = join ' ', @{$newdata{$field}||[]}; - } + %newdata = encode_utf8_structure(%newdata); if ($version < 3) { for my $field (@rfc1522_fields) { @@ -313,6 +628,13 @@ sub makestatus { } } + # this is a bit of a hack; we should never, ever have \r or \n in + # the fields of status. Kill them off here. [Eventually, this + # should be superfluous.] + for my $field (keys %newdata) { + $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field}; + } + if ($version == 1) { for my $field (@v1fieldorder) { if (exists $newdata{$field} and defined $newdata{$field}) { @@ -331,11 +653,11 @@ sub makestatus { # Output field names in proper case, e.g. 'Merged-With'. my $properfield = $fields{$field}; $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g; - $contents .= "$properfield: $newdata{$field}\n"; + my $data = $newdata{$field}; + $contents .= "$properfield: $data\n"; } } } - return $contents; } @@ -355,21 +677,29 @@ sub writebug { my ($ref, $data, $location, $minversion, $disablebughook) = @_; my $change; - my %outputs = (1 => 'status', 2 => 'summary'); + my %outputs = (1 => 'status', 3 => 'summary'); for my $version (keys %outputs) { next if defined $minversion and $version < $minversion; my $status = getbugcomponent($ref, $outputs{$version}, $location); - &quit("can't find location for $ref") unless defined $status; - open(S,"> $status.new") || &quit("opening $status.new: $!"); - print(S makestatus($data, $version)) || - &quit("writing $status.new: $!"); - close(S) || &quit("closing $status.new: $!"); + die "can't find location for $ref" unless defined $status; + my $sfh; + if ($version >= 3) { + open $sfh,">","$status.new" or + die "opening $status.new: $!"; + } + else { + open $sfh,">","$status.new" or + die "opening $status.new: $!"; + } + print {$sfh} makestatus($data, $version) or + die "writing $status.new: $!"; + close($sfh) or die "closing $status.new: $!"; if (-e $status) { $change = 'change'; } else { $change = 'new'; } - rename("$status.new",$status) || &quit("installing new $status: $!"); + rename("$status.new",$status) || die "installing new $status: $!"; } # $disablebughook is a bit of a hack to let format migration scripts use @@ -388,7 +718,7 @@ options mean. sub unlockwritebug { writebug(@_); - &unfilelock; + unfilelock(); } =head1 VERSIONS @@ -399,7 +729,7 @@ The following functions are exported with the :versions tag addfoundversions($status,$package,$version,$isbinary); - +All use of this should be phased out in favor of Debbugs::Control::fixed/found =cut @@ -412,9 +742,14 @@ sub addfoundversions { return unless defined $version; undef $package if $package =~ m[(?:\s|/)]; my $source = $package; + if ($package =~ s/^src://) { + $isbinary = 0; + $source = $package; + } if (defined $package and $isbinary) { - my @srcinfo = binarytosource($package, $version, undef); + my @srcinfo = binary_to_source(binary => $package, + version => $version); if (@srcinfo) { # We know the source package(s). Use a fully-qualified version. addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo; @@ -488,7 +823,8 @@ sub addfixedversions { my $source = $package; if (defined $package and $isbinary) { - my @srcinfo = binarytosource($package, $version, undef); + my @srcinfo = binary_to_source(binary => $package, + version => $version); if (@srcinfo) { # We know the source package(s). Use a fully-qualified version. addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; @@ -519,24 +855,20 @@ sub removefixedversions { my $version = shift; my $isbinary = shift; return unless defined $version; - undef $package if $package =~ m[(?:\s|/)]; - my $source = $package; - - if (defined $package and $isbinary) { - my @srcinfo = binarytosource($package, $version, undef); - if (@srcinfo) { - # We know the source package(s). Use a fully-qualified version. - removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; - return; - } - # Otherwise, an unqualified version will have to do. - undef $source; - } foreach my $ver (split /[,\s]+/, $version) { - my $sver = defined($source) ? "$source/$ver" : ''; - @{$data->{fixed_versions}} = - grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}}; + if ($ver =~ m{/}) { + # fully qualified version + @{$data->{fixed_versions}} = + grep {$_ ne $ver} + @{$data->{fixed_versions}}; + } + else { + # non qualified version; delete all matchers + @{$data->{fixed_versions}} = + grep {$_ !~ m[(?:^|/)\Q$ver\E$]} + @{$data->{fixed_versions}}; + } } } @@ -553,7 +885,7 @@ Split a package string from the status file into a list of package names. sub splitpackages { my $pkgs = shift; return unless defined $pkgs; - return map lc, split /[ \t?,()]+/, $pkgs; + return grep {length $_} map lc, split /[\s,()?]+/, $pkgs; } @@ -610,17 +942,44 @@ sub bug_archiveable{ my $status = $param{status}; if (not exists $param{status} or not defined $status) { $status = read_bug(bug=>$param{bug}); - return undef if not defined $status; + if (not defined $status) { + print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG; + return undef; + } } # Bugs can be archived if they are # 1. Closed - return $cannot_archive if not defined $status->{done} or not length $status->{done}; + if (not defined $status->{done} or not length $status->{done}) { + print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG; + return $cannot_archive + } + # Check to make sure that the bug has none of the unremovable tags set + if (@{$config{removal_unremovable_tags}}) { + for my $tag (split ' ', ($status->{keywords}||'')) { + if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) { + print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG; + return $cannot_archive; + } + } + } + # If we just are checking if the bug can be archived, we'll not even bother # checking the versioning information if the bug has been -done for less than 28 days. + my $log_file = getbugcomponent($param{bug},'log'); + if (not defined $log_file) { + print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG; + return $cannot_archive; + } + my $max_log_age = max(map {$config{remove_age} - -M $_} + $log_file, map {my $log = getbugcomponent($_,'log'); + defined $log ? ($log) : (); + } + split / /, $status->{mergedwith} + ); if (not $param{days_until} and not $param{ignore_time} - and $config{remove_age} > - -M getbugcomponent($param{bug},'log') + and $max_log_age > 0 ) { + print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG; return $cannot_archive; } # At this point, we have to get the versioning information for this bug. @@ -628,6 +987,10 @@ sub bug_archiveable{ # tags set, we assume a default set, otherwise we use the tags the bug # has set. + # In cases where we are assuming a default set, if the severity + # is strong, we use the strong severity default; otherwise, we + # use the normal default. + # There must be fixed_versions for us to look at the versioning # information my $min_fixed_time = time; @@ -637,11 +1000,20 @@ sub bug_archiveable{ @dist_tags{@{$config{removal_distribution_tags}}} = (1) x @{$config{removal_distribution_tags}}; my %dists; - @dists{@{$config{removal_default_distribution_tags}}} = - (1) x @{$config{removal_default_distribution_tags}}; - for my $tag (split ' ', ($status->{tags}||'')) { - next unless $dist_tags{$tag}; - $dists{$tag} = 1; + for my $tag (split ' ', ($status->{keywords}||'')) { + next unless exists $config{distribution_aliases}{$tag}; + next unless $dist_tags{$config{distribution_aliases}{$tag}}; + $dists{$config{distribution_aliases}{$tag}} = 1; + } + if (not keys %dists) { + if (isstrongseverity($status->{severity})) { + @dists{@{$config{removal_strong_severity_default_distribution_tags}}} = + (1) x @{$config{removal_strong_severity_default_distribution_tags}}; + } + else { + @dists{@{$config{removal_default_distribution_tags}}} = + (1) x @{$config{removal_default_distribution_tags}}; + } } my %source_versions; my @sourceversions = get_versions(package => $status->{package}, @@ -658,6 +1030,7 @@ sub bug_archiveable{ version_cache => $version_cache, package => $status->{package}, )) { + print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG; return $cannot_archive; } # Since the bug has at least been fixed in the architectures @@ -688,15 +1061,19 @@ sub bug_archiveable{ last if $buggy eq 'found'; $min_fixed_time = min($time_versions{$version},$min_fixed_time); } - $min_archive_days = max($min_archive_days,ceil((time - $min_fixed_time)/(60*60*24))); + $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24))) + # if there are no versions in the archive at all, then + # we can archive if enough days have passed + if @sourceversions; } # If $param{ignore_time}, then we should ignore time. if ($param{ignore_time}) { return $param{days_until}?0:1; } # 6. at least 28 days have passed since the last action has occured or the bug was closed - my $age = ceil($config{remove_age} - -M getbugcomponent($param{bug},'log')); + my $age = ceil($max_log_age); if ($age > 0 or $min_archive_days > 0) { + print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG; return $param{days_until}?max($age,$min_archive_days):0; } else { @@ -729,12 +1106,16 @@ currently not correctly implemented. =item arch -- optional architecture(s) to check package status at -=item usertags -- optional hashref of usertags +=item bugusertags -- optional hashref of bugusertags =item sourceversion -- optional arrayref of source/version; overrides dist, arch, and version. [The entries in this array must be in the "source/version" format.] Eventually this can be used to for caching. +=item indicatesource -- if true, indicate which source packages this +bug could belong to (or does belong to in the case of bugs assigned to +a source package). Defaults to true. + =back Note: Currently the version information is cached; this needs to be @@ -765,12 +1146,15 @@ sub get_bug_status { arch => {type => SCALAR|ARRAYREF, optional => 1, }, - usertags => {type => HASHREF, - optional => 1, - }, + bugusertags => {type => HASHREF, + optional => 1, + }, sourceversions => {type => ARRAYREF, optional => 1, }, + indicatesource => {type => BOOLEAN, + default => 1, + }, }, ); my %status; @@ -787,22 +1171,28 @@ sub get_bug_status { } else { my $location = getbuglocation($param{bug}, 'summary'); - return {} if not length $location; + return {} if not defined $location or not length $location; %status = %{ readbug( $param{bug}, $location ) }; } $status{id} = $param{bug}; - if (defined $param{usertags}{$param{bug}}) { + if (defined $param{bugusertags}{$param{bug}}) { $status{keywords} = "" unless defined $status{keywords}; $status{keywords} .= " " unless $status{keywords} eq ""; - $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}}); + $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}}); } $status{tags} = $status{keywords}; my %tags = map { $_ => 1 } split ' ', $status{tags}; + $status{package} = '' if not defined $status{package}; $status{"package"} =~ s/\s*$//; + + $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}], + source_only => 1, + ); + $status{"package"} = 'unknown' if ($status{"package"} eq ''); - $status{"severity"} = 'normal' if ($status{"severity"} eq ''); + $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq ''); $status{"pending"} = 'pending'; $status{"pending"} = 'forwarded' if (length($status{"forwarded"})); @@ -810,7 +1200,8 @@ sub get_bug_status { $status{"pending"} = 'fixed' if ($tags{fixed}); - my $presence = bug_presence(map{(exists $param{$_})?($_,$param{$_}):()} + my $presence = bug_presence(status => \%status, + map{(exists $param{$_})?($_,$param{$_}):()} qw(bug sourceversions arch dist version found fixed package) ); if (defined $presence) { @@ -894,32 +1285,88 @@ sub bug_presence { } my @sourceversions; + my $pseudo_desc = getpseudodesc(); if (not exists $param{sourceversions}) { my %sourceversions; - if (defined $param{version}) { + # pseudopackages do not have source versions by definition. + if (exists $pseudo_desc->{$status{package}}) { + # do nothing. + } + elsif (defined $param{version}) { foreach my $arch (make_list($param{arch})) { - my @temp = makesourceversions($status{package}, - $arch, - make_list($param{version}) - ); - @sourceversions{@temp} = (1) x @temp; + for my $package (split /\s*,\s*/, $status{package}) { + my @temp = makesourceversions($package, + $arch, + make_list($param{version}) + ); + @sourceversions{@temp} = (1) x @temp; + } } } elsif (defined $param{dist}) { - foreach my $arch (make_list($param{arch})) { - my @versions; - foreach my $dist (make_list($param{dist})) { - push @versions, getversions($status{package}, $dist, $arch); + my %affects_distribution_tags; + @affects_distribution_tags{@{$config{affects_distribution_tags}}} = + (1) x @{$config{affects_distribution_tags}}; + my $some_distributions_disallowed = 0; + my %allowed_distributions; + for my $tag (split ' ', ($status{keywords}||'')) { + if (exists $config{distribution_aliases}{$tag} and + exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) { + $some_distributions_disallowed = 1; + $allowed_distributions{$config{distribution_aliases}{$tag}} = 1; + } + elsif (exists $affects_distribution_tags{$tag}) { + $some_distributions_disallowed = 1; + $allowed_distributions{$tag} = 1; + } + } + my @archs = make_list(exists $param{arch}?$param{arch}:()); + GET_SOURCE_VERSIONS: + foreach my $arch (@archs) { + for my $package (split /\s*,\s*/, $status{package}) { + my @versions = (); + my $source = 0; + if ($package =~ /^src:(.+)$/) { + $source = 1; + $package = $1; + } + foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) { + # if some distributions are disallowed, + # and this isn't an allowed + # distribution, then we ignore this + # distribution for the purposees of + # finding versions + if ($some_distributions_disallowed and + not exists $allowed_distributions{$dist}) { + next; + } + push @versions, get_versions(package => $package, + dist => $dist, + ($source?(arch => 'source'): + (defined $arch?(arch => $arch):())), + ); + } + next unless @versions; + my @temp = make_source_versions(package => $package, + arch => $arch, + versions => \@versions, + ); + @sourceversions{@temp} = (1) x @temp; } - my @temp = makesourceversions($status{package}, - $arch, - @versions - ); - @sourceversions{@temp} = (1) x @temp; } + # this should really be split out into a subroutine, + # but it'd touch so many things currently, that we fake + # it; it's needed to properly handle bugs which are + # erroneously assigned to the binary package, and we'll + # probably have it go away eventually. + if (not keys %sourceversions and (not @archs or defined $archs[0])) { + @archs = (undef); + goto GET_SOURCE_VERSIONS; + } } # TODO: This should probably be handled further out for efficiency and # for more ease of distinguishing between pkg= and src= queries. + # DLA: src= queries should just pass arch=source, and they'll be happy. @sourceversions = keys %sourceversions; } else { @@ -928,14 +1375,15 @@ sub bug_presence { my $maxbuggy = 'undef'; if (@sourceversions) { $maxbuggy = max_buggy(bug => $param{bug}, - sourceversions => \@sourceversions, - found => $status{found_versions}, - fixed => $status{fixed_versions}, - package => $status{package}, - version_cache => $version_cache, - ); + sourceversions => \@sourceversions, + found => $status{found_versions}, + fixed => $status{fixed_versions}, + package => $status{package}, + version_cache => $version_cache, + ); } - elsif (defined $param{dist}) { + elsif (defined $param{dist} and + not exists $pseudo_desc->{$status{package}}) { return 'absent'; } if (length($status{done}) and @@ -991,18 +1439,20 @@ sub max_buggy{ # Resolve bugginess states (we might be looking at multiple # architectures, say). Found wins, then fixed, then absent. my $maxbuggy = 'absent'; - for my $version (@{$param{sourceversions}}) { - my $buggy = buggy(bug => $param{bug}, - version => $version, - found => $param{found}, - fixed => $param{fixed}, - version_cache => $param{version_cache}, - package => $param{package}, - ); - if ($buggy eq 'found') { - return 'found'; - } elsif ($buggy eq 'fixed') { - $maxbuggy = 'fixed'; + for my $package (split /\s*,\s*/, $param{package}) { + for my $version (@{$param{sourceversions}}) { + my $buggy = buggy(bug => $param{bug}, + version => $version, + found => $param{found}, + fixed => $param{fixed}, + version_cache => $param{version_cache}, + package => $package, + ); + if ($buggy eq 'found') { + return 'found'; + } elsif ($buggy eq 'fixed') { + $maxbuggy = 'fixed'; + } } } return $maxbuggy; @@ -1060,23 +1510,31 @@ sub buggy { ); } if ($param{version} !~ m{/}) { - $param{version} = makesourceversions($param{package},undef, - $param{version} - ); + my ($version) = makesourceversions($param{package},undef, + $param{version} + ); + $param{version} = $version if defined $version; } # Figure out which source packages we need my %sources; @sources{map {m{(.+)/}; $1} @found} = (1) x @found; @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed; - @sources{map {m{(.+)/}; $1} $param{version}} = 1; + @sources{map {m{(.+)/}; $1} $param{version}} = 1 if + $param{version} =~ m{/}; my $version; if (not defined $param{version_cache} or not exists $param{version_cache}{join(',',sort keys %sources)}) { $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp); foreach my $source (keys %sources) { my $srchash = substr $source, 0, 1; - my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r' or - warn "Unable to open $config{version_packages_dir}/$srchash/$source: $!" and next; + my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r'); + if (not defined $version_fh) { + # We only want to warn if it's a package which actually has a maintainer + my $maints = getmaintainers(); + next if not exists $maints->{$source}; + warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!"; + next; + } $version->load($version_fh); } if (defined $param{version_cache}) { @@ -1091,7 +1549,8 @@ sub buggy { sub isstrongseverity { my $severity = shift; - $severity = $config{default_severity} if $severity eq ''; + $severity = $config{default_severity} if + not defined $severity or $severity eq ''; return grep { $_ eq $severity } @{$config{strong_severities}}; } @@ -1101,79 +1560,97 @@ sub isstrongseverity { =cut sub update_realtime { - my ($file, $bug, $new) = @_; + my ($file, %bugs) = @_; # update realtime index.db - open(IDXDB, "<$file") or die "Couldn't open $file"; - open(IDXNEW, ">$file.new"); + return () unless keys %bugs; + my $idx_old = IO::File->new($file,'r') + or die "Couldn't open ${file}: $!"; + my $idx_new = IO::File->new($file.'.new','w') + or die "Couldn't open ${file}.new: $!"; + my $min_bug = min(keys %bugs); my $line; my @line; - while($line = ) { - @line = split /\s/, $line; - last if ($line[1] >= $bug); - print IDXNEW $line; - $line = ""; - } - - if ($new eq "NOCHANGE") { - print IDXNEW $line if ($line ne "" and $line[1] == $bug); - } elsif ($new eq "REMOVE") { - 0; - } else { - print IDXNEW $new; - } - if (defined $line and $line ne "" and @line and $line[1] > $bug) { - print IDXNEW $line; - $line = ""; + my %changed_bugs; + while($line = <$idx_old>) { + @line = split /\s/, $line; + # Two cases; replacing existing line or adding new line + if (exists $bugs{$line[1]}) { + my $new = $bugs{$line[1]}; + delete $bugs{$line[1]}; + $min_bug = min(keys %bugs); + if ($new eq "NOCHANGE") { + print {$idx_new} $line; + $changed_bugs{$line[1]} = $line; + } elsif ($new eq "REMOVE") { + $changed_bugs{$line[1]} = $line; + } else { + print {$idx_new} $new; + $changed_bugs{$line[1]} = $line; + } + } + else { + while ($line[1] > $min_bug) { + print {$idx_new} $bugs{$min_bug}; + delete $bugs{$min_bug}; + last unless keys %bugs; + $min_bug = min(keys %bugs); + } + print {$idx_new} $line; + } + last unless keys %bugs; } + print {$idx_new} map {$bugs{$_}} sort keys %bugs; - print IDXNEW while(); + print {$idx_new} <$idx_old>; - close(IDXNEW); - close(IDXDB); + close($idx_new); + close($idx_old); rename("$file.new", $file); - return $line; + return %changed_bugs; } sub bughook_archive { - my $ref = shift; - &filelock("debbugs.trace.lock"); - &appendfile("debbugs.trace","archive $ref\n"); - my $line = update_realtime( - "$config{spool_dir}/index.db.realtime", - $ref, - "REMOVE"); + my @refs = @_; + filelock("$config{spool_dir}/debbugs.trace.lock"); + appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n"); + my %bugs = update_realtime("$config{spool_dir}/index.db.realtime", + map{($_,'REMOVE')} @refs); update_realtime("$config{spool_dir}/index.archive.realtime", - $ref, $line); - &unfilelock; + %bugs); + unfilelock(); } sub bughook { - my ( $type, $ref, $data ) = @_; - &filelock("debbugs.trace.lock"); - - &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1)); - - my $whendone = "open"; - my $severity = $config{default_severity}; - (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g; - $pkglist =~ s/^,+//; - $pkglist =~ s/,+$//; - $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded}; - $whendone = "done" if defined $data->{done} and length $data->{done}; - $severity = $data->{severity} if length $data->{severity}; - - my $k = sprintf "%s %d %d %s [%s] %s %s\n", - $pkglist, $ref, $data->{date}, $whendone, - $data->{originator}, $severity, $data->{keywords}; - - update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k); + my ( $type, %bugs_temp ) = @_; + filelock("$config{spool_dir}/debbugs.trace.lock"); + + my %bugs; + for my $bug (keys %bugs_temp) { + my $data = $bugs_temp{$bug}; + appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1)); + + my $whendone = "open"; + my $severity = $config{default_severity}; + (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g; + $pkglist =~ s/^,+//; + $pkglist =~ s/,+$//; + $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded}; + $whendone = "done" if defined $data->{done} and length $data->{done}; + $severity = $data->{severity} if length $data->{severity}; + + my $k = sprintf "%s %d %d %s [%s] %s %s\n", + $pkglist, $bug, $data->{date}, $whendone, + $data->{originator}, $severity, $data->{keywords}; + $bugs{$bug} = $k; + } + update_realtime("$config{spool_dir}/index.db.realtime", %bugs); - &unfilelock; + unfilelock(); }