2 package Debbugs::Status;
6 Debbugs::Status -- Routines for dealing with summary and status files
15 This module is a replacement for the parts of errorlib.pl which write
16 and read status and summary files.
18 It also contains generic routines for returning information about the
19 status of a particular bug
27 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
28 use base qw(Exporter);
30 use Params::Validate qw(validate_with :types);
31 use Debbugs::Common qw(:util :lock);
32 use Debbugs::Config qw(:config);
33 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
38 $DEBUG = 0 unless defined $DEBUG;
41 %EXPORT_TAGS = (status => [qw(splitpackages)],
42 read => [qw(readbug lockreadbug)],
43 write => [qw(writebug makestatus unlockwritebug)],
44 versions => [qw(addfoundversion addfixedversion),
48 Exporter::export_ok_tags(qw(status read write versions));
49 $EXPORT_TAGS{all} = [@EXPORT_OK];
55 readbug($bug_number,$location)
57 Reads a summary file from the archive given a bug number and a bug
58 location. Valid locations are those understood by L</getbugcomponent>
63 my %fields = (originator => 'submitter',
66 msgid => 'message-id',
67 'package' => 'package',
70 forwarded => 'forwarded-to',
71 mergedwith => 'merged-with',
72 severity => 'severity',
74 found_versions => 'found-in',
75 found_date => 'found-date',
76 fixed_versions => 'fixed-in',
77 fixed_date => 'fixed-date',
79 blockedby => 'blocked-by',
82 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
83 my @rfc1522_fields = qw(originator subject done forwarded owner);
87 readbug($bug_num,$location);
91 Retreives the information from the summary files for a particular bug
92 number. If location is not specified, getbuglocation is called to fill
98 my ($lref, $location) = @_;
99 if (not defined $location) {
100 $location = getbuglocation($lref,'summary');
101 return undef if not defined $location;
103 my $status = getbugcomponent($lref, 'summary', $location);
104 return undef unless defined $status;
105 my $status_fh = new IO::File $status, 'r' or
106 warn "Unable to open $status for reading: $!" and return undef;
113 while (<$status_fh>) {
116 $version = $1 if /^Format-Version: ([0-9]+)/i;
119 # Version 3 is the latest format version currently supported.
120 return undef if $version > 3;
122 my %namemap = reverse %fields;
123 for my $line (@lines) {
124 if ($line =~ /(\S+?): (.*)/) {
125 my ($name, $value) = (lc $1, $2);
126 $data{$namemap{$name}} = $value if exists $namemap{$name};
129 for my $field (keys %fields) {
130 $data{$field} = '' unless exists $data{$field};
133 $data{severity} = $config{default_severity} if $data{severity} eq '';
134 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
135 $data{$field} = [split ' ', $data{$field}];
137 for my $field (qw(found fixed)) {
138 @{$data{$field}}{@{$data{"${field}_versions"}}} =
139 (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
140 @{$data{"${field}_date"}});
144 for my $field (@rfc1522_fields) {
145 $data{$field} = decode_rfc1522($data{$field});
154 lockreadbug($bug_num,$location)
156 Performs a filelock, then reads the bug; the bug is unlocked if the
157 return is undefined, otherwise, you need to call unfilelock or
160 See readbug above for information on what this returns
165 my ($lref, $location) = @_;
166 &filelock("lock/$lref");
167 my $data = readbug($lref, $location);
168 &unfilelock unless defined $data;
172 my @v1fieldorder = qw(originator date subject msgid package
173 keywords done forwarded mergedwith severity);
177 my $content = makestatus($status,$version)
178 my $content = makestatus($status);
180 Creates the content for a status file based on the $status hashref
183 Really only useful for writebug
185 Currently defaults to version 2 (non-encoded rfc1522 names) but will
186 eventually default to version 3. If you care, you should specify a
192 my ($data,$version) = @_;
193 $version = 2 unless defined $version;
197 my %newdata = %$data;
198 for my $field (qw(found fixed)) {
199 if (exists $newdata{$field}) {
200 $newdata{"${field}_date"} =
201 [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
205 for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
206 $newdata{$field} = [split ' ', $newdata{$field}];
210 for my $field (@rfc1522_fields) {
211 $newdata{$field} = encode_rfc1522($newdata{$field});
216 for my $field (@v1fieldorder) {
217 if (exists $newdata{$field}) {
218 $contents .= "$newdata{$field}\n";
223 } elsif ($version == 2 or $version == 3) {
224 # Version 2 or 3. Add a file format version number for the sake of
225 # further extensibility in the future.
226 $contents .= "Format-Version: $version\n";
227 for my $field (keys %fields) {
228 if (exists $newdata{$field} and $newdata{$field} ne '') {
229 # Output field names in proper case, e.g. 'Merged-With'.
230 my $properfield = $fields{$field};
231 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
232 $contents .= "$properfield: $newdata{$field}\n";
242 writebug($bug_num,$status,$location,$minversion,$disablebughook)
244 Writes the bug status and summary files out.
246 Skips writting out a status file if minversion is 2
248 Does not call bughook if disablebughook is true.
253 my ($ref, $data, $location, $minversion, $disablebughook) = @_;
256 my %outputs = (1 => 'status', 2 => 'summary');
257 for my $version (keys %outputs) {
258 next if defined $minversion and $version < $minversion;
259 my $status = getbugcomponent($ref, $outputs{$version}, $location);
260 &quit("can't find location for $ref") unless defined $status;
261 open(S,"> $status.new") || &quit("opening $status.new: $!");
262 print(S makestatus($data, $version)) ||
263 &quit("writing $status.new: $!");
264 close(S) || &quit("closing $status.new: $!");
270 rename("$status.new",$status) || &quit("installing new $status: $!");
273 # $disablebughook is a bit of a hack to let format migration scripts use
274 # this function rather than having to duplicate it themselves.
275 &bughook($change,$ref,$data) unless $disablebughook;
278 =head2 unlockwritebug
280 unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
282 Writes a bug, then calls unfilelock; see writebug for what these
294 The following functions are exported with the :versions tag
296 =head2 addfoundversions
298 addfoundversions($status,$package,$version,$isbinary);
305 sub addfoundversions {
309 my $isbinary = shift;
310 return unless defined $version;
311 undef $package if $package =~ m[(?:\s|/)];
312 my $source = $package;
314 if (defined $package and $isbinary) {
315 my @srcinfo = binarytosource($package, $version, undef);
317 # We know the source package(s). Use a fully-qualified version.
318 addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
321 # Otherwise, an unqualified version will have to do.
325 # Strip off various kinds of brain-damage.
327 $version =~ s/ *\(.*\)//;
328 $version =~ s/ +[A-Za-z].*//;
330 foreach my $ver (split /[,\s]+/, $version) {
331 my $sver = defined($source) ? "$source/$ver" : '';
332 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
333 push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
335 @{$data->{fixed_versions}} =
336 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
340 sub removefoundversions {
344 my $isbinary = shift;
345 return unless defined $version;
346 undef $package if $package =~ m[(?:\s|/)];
347 my $source = $package;
349 if (defined $package and $isbinary) {
350 my @srcinfo = binarytosource($package, $version, undef);
352 # We know the source package(s). Use a fully-qualified version.
353 removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
356 # Otherwise, an unqualified version will have to do.
360 foreach my $ver (split /[,\s]+/, $version) {
361 my $sver = defined($source) ? "$source/$ver" : '';
362 @{$data->{found_versions}} =
363 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
367 sub addfixedversions {
371 my $isbinary = shift;
372 return unless defined $version;
373 undef $package if $package =~ m[(?:\s|/)];
374 my $source = $package;
376 if (defined $package and $isbinary) {
377 my @srcinfo = binarytosource($package, $version, undef);
379 # We know the source package(s). Use a fully-qualified version.
380 addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
383 # Otherwise, an unqualified version will have to do.
387 # Strip off various kinds of brain-damage.
389 $version =~ s/ *\(.*\)//;
390 $version =~ s/ +[A-Za-z].*//;
392 foreach my $ver (split /[,\s]+/, $version) {
393 my $sver = defined($source) ? "$source/$ver" : '';
394 unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
395 push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
397 @{$data->{found_versions}} =
398 grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
402 sub removefixedversions {
406 my $isbinary = shift;
407 return unless defined $version;
408 undef $package if $package =~ m[(?:\s|/)];
409 my $source = $package;
411 if (defined $package and $isbinary) {
412 my @srcinfo = binarytosource($package, $version, undef);
414 # We know the source package(s). Use a fully-qualified version.
415 removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
418 # Otherwise, an unqualified version will have to do.
422 foreach my $ver (split /[,\s]+/, $version) {
423 my $sver = defined($source) ? "$source/$ver" : '';
424 @{$data->{fixed_versions}} =
425 grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
435 Split a package string from the status file into a list of package names.
441 return unless defined $pkgs;
442 return map lc, split /[ \t?,()]+/, $pkgs;
446 =head2 bug_archiveable
448 bug_archiveable(ref => $bug_num);
454 =item ref -- bug number (required)
456 =item status -- Status hashref (optional)
458 =item version -- Debbugs::Version information (optional)
460 =item days_until -- return days until the bug can be archived
464 Returns 1 if the bug can be archived
465 Returns 0 if the bug cannot be archived
467 If days_until is true, returns the number of days until the bug can be
468 archived, -1 if it cannot be archived.
473 my %param = validate_with(params => \@_,
474 spec => {ref => {type => SCALAR,
477 status => {type => HASHREF,
480 version => {type => HASHREF,
483 days_until => {type => BOOLEAN,
488 # read the status information
489 # read the version information
490 # Bugs can be archived if they are
492 # 2. Fixed in unstable if tagged unstable
493 # 3. Fixed in stable if tagged stable
494 # 4. Fixed in testing if tagged testing
495 # 5. Fixed in experimental if tagged experimental
496 # 6. at least 28 days have passed since the last action has occured or the bug was closed
499 =head1 PRIVATE FUNCTIONS
503 sub update_realtime {
504 my ($file, $bug, $new) = @_;
506 # update realtime index.db
508 open(IDXDB, "<$file") or die "Couldn't open $file";
509 open(IDXNEW, ">$file.new");
513 while($line = <IDXDB>) {
514 @line = split /\s/, $line;
515 last if ($line[1] >= $bug);
520 if ($new eq "NOCHANGE") {
521 print IDXNEW $line if ($line ne "" && $line[1] == $bug);
522 } elsif ($new eq "REMOVE") {
527 if ($line ne "" && $line[1] > $bug) {
532 print IDXNEW while(<IDXDB>);
537 rename("$file.new", $file);
542 sub bughook_archive {
544 &filelock("debbugs.trace.lock");
545 &appendfile("debbugs.trace","archive $ref\n");
546 my $line = update_realtime(
547 "$config{spool_dir}/index.db.realtime",
550 update_realtime("$config{spool_dir}/index.archive.realtime",
556 my ( $type, $ref, $data ) = @_;
557 &filelock("debbugs.trace.lock");
559 &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
561 my $whendone = "open";
562 my $severity = $config{default_severity};
563 (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
566 $whendone = "forwarded" if length $data->{forwarded};
567 $whendone = "done" if length $data->{done};
568 $severity = $data->{severity} if length $data->{severity};
570 my $k = sprintf "%s %d %d %s [%s] %s %s\n",
571 $pkglist, $ref, $data->{date}, $whendone,
572 $data->{originator}, $severity, $data->{keywords};
574 update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);