#
# [Other people have contributed to this file; their copyrights should
# go here too.]
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+# Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Status;
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;
@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),
],
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];
}
=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',
affects => 'affects',
);
+
# Fields which need to be RFC1522-decoded in format versions earlier than 3.
my @rfc1522_fields = qw(originator subject done forwarded owner);
something modifying it while the bug has been read. You B<must> call
C<unfilelock();> 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<bug> or C<summary> must be passed. This function will return
lock => {type => BOOLEAN,
optional => 1,
},
+ locks => {type => HASHREF,
+ optional => 1,
+ },
},
);
die "One of bug or summary must be passed to read_bug"
$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};
($location) = $status =~ m/(db-h|db|archive)/;
}
if ($param{lock}) {
- filelock("$config{spool_dir}/lock/$param{bug}");
+ 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();
+ unfilelock(exists $param{locks}?$param{locks}:());
}
return undef;
}
if ($version > 3) {
warn "Unsupported status version '$version'";
if ($param{lock}) {
- unfilelock();
+ 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}];
@{$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];
+}
+
+=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)
=cut
sub lock_read_all_merged_bugs {
- my ($bug_num,$location) = @_;
+ 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 = (lockreadbug(@_));
+ 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,undef);
+ return ($locks,());
}
$locks++;
if (not length $data[0]->{mergedwith}) {
return ($locks,@data);
}
- unfilelock();
+ unfilelock(exists $param{locks}?$param{locks}:());
$locks--;
- filelock("$config{spool_dir}/lock/merge");
+ filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:());
$locks++;
- @data = (lockreadbug(@_));
+ @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(); #for merge lock above
+ unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above
$locks--;
- return ($locks,undef);
+ return ($locks,());
}
$locks++;
my @bugs = split / /, $data[0]->{mergedwith};
+ push @bugs, $param{bug};
for my $bug (@bugs) {
my $newdata = undef;
- if ($bug ne $bug_num) {
- $newdata = lockreadbug($bug,$location);
+ 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();
+ unfilelock(exists $param{locks}?$param{locks}:());
}
$locks = 0;
- warn "Unable to read bug: $bug while handling merged bug: $bug_num";
- return ($locks,undef);
+ 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,$bug_num));
- if ($newdata->{mergedwith} ne $expectmerge) {
- for (1..$locks) {
- unfilelock();
+ # 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).")";
}
- die "Bug $bug_num 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);
sub makestatus {
my ($data,$version) = @_;
- $version = 2 unless defined $version;
+ $version = 3 unless defined $version;
my $contents = '';
[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) {
}
}
+ # 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}) {
# 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;
}
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);
die "can't find location for $ref" unless defined $status;
- open(S,"> $status.new") || die "opening $status.new: $!";
- print(S makestatus($data, $version)) ||
+ 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(S) || die "closing $status.new: $!";
+ close($sfh) or die "closing $status.new: $!";
if (-e $status) {
$change = 'change';
} else {
sub unlockwritebug {
writebug(@_);
- &unfilelock;
+ unfilelock();
}
=head1 VERSIONS
addfoundversions($status,$package,$version,$isbinary);
-
+All use of this should be phased out in favor of Debbugs::Control::fixed/found
=cut
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;
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;
sub splitpackages {
my $pkgs = shift;
return unless defined $pkgs;
- return map lc, split /[ \t?,()]+/, $pkgs;
+ return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
}
}
# Check to make sure that the bug has none of the unremovable tags set
if (@{$config{removal_unremovable_tags}}) {
- for my $tag (split ' ', ($status->{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;
@dist_tags{@{$config{removal_distribution_tags}}} =
(1) x @{$config{removal_distribution_tags}};
my %dists;
- for my $tag (split ' ', ($status->{tags}||'')) {
+ 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;
"source/version" format.] Eventually this can be used to for caching.
=item indicatesource -- if true, indicate which source packages this
-bug could belong to. Defaults to false. [Note that eventually we will
-properly allow bugs that only affect a source package, and this will
-become always on.]
+bug could belong to (or does belong to in the case of bugs assigned to
+a source package). Defaults to true.
=back
optional => 1,
},
indicatesource => {type => BOOLEAN,
- default => 0,
+ default => 1,
},
},
);
$status{tags} = $status{keywords};
my %tags = map { $_ => 1 } split ' ', $status{tags};
+ $status{package} = '' if not defined $status{package};
$status{"package"} =~ s/\s*$//;
- if ($param{indicatesource} and $status{package} ne '') {
- $status{source} = join(', ',binarytosource($status{package}));
- }
- else {
- $status{source} = 'unknown';
- }
+
+ $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"}));
(1) x @{$config{affects_distribution_tags}};
my $some_distributions_disallowed = 0;
my %allowed_distributions;
- for my $tag (split ' ', ($status->{tags}||'')) {
- if (exists $affects_distribution_tags{$tag}) {
- $some_distributions_disallowed = 1;
- $allowed_distributions{$tag} = 1;
- }
+ 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;
+ }
}
- foreach my $arch (make_list($param{arch})) {
- for my $package (split /\s*,\s*/, $status{package}) {
- my @versions;
- foreach my $dist (make_list($param{dist})) {
+ 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{$tag}) {
+ not exists $allowed_distributions{$dist}) {
next;
}
- push @versions, getversions($package, $dist, $arch);
+ push @versions, get_versions(package => $package,
+ dist => $dist,
+ ($source?(arch => 'source'):
+ (defined $arch?(arch => $arch):())),
+ );
}
next unless @versions;
- my @temp = makesourceversions($package,
- $arch,
- @versions
- );
+ my @temp = make_source_versions(package => $package,
+ arch => $arch,
+ versions => \@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
sub bughook_archive {
my @refs = @_;
- &filelock("$config{spool_dir}/debbugs.trace.lock");
- &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
+ 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",
%bugs);
- &unfilelock;
+ unfilelock();
}
sub bughook {
my ( $type, %bugs_temp ) = @_;
- &filelock("$config{spool_dir}/debbugs.trace.lock");
+ filelock("$config{spool_dir}/debbugs.trace.lock");
my %bugs;
for my $bug (keys %bugs_temp) {
my $data = $bugs_temp{$bug};
- &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
+ appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
my $whendone = "open";
my $severity = $config{default_severity};
}
update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
- &unfilelock;
+ unfilelock();
}
projects / debbugs.git / blobdiff