X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FStatus.pm;h=3b3961f90667ec7cbf654a371f49aa8d9399ad6d;hb=e70cd2221904f79524d0e60e30506e13b6fc9cfa;hp=94254922c7f1d8fb0002caf37b8123c2a4b009a4;hpb=eaebd4ad47eea544709473b9409499b40fce3101;p=debbugs.git

diff --git a/Debbugs/Status.pm b/Debbugs/Status.pm
index 9425492..797bbdd 100644
--- a/Debbugs/Status.pm
+++ b/Debbugs/Status.pm
@@ -1,3 +1,11 @@
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
 
 package Debbugs::Status;
 
@@ -24,46 +32,70 @@ status of a particular bug
 
 use warnings;
 use strict;
+
+use feature 'state';
+
 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use base qw(Exporter);
+use Exporter qw(import);
 
 use Params::Validate qw(validate_with :types);
-use Debbugs::Common qw(:util :lock);
+use Debbugs::Common qw(:util :lock :quit :misc);
+use Debbugs::UTF8;
 use Debbugs::Config qw(:config);
 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
-use Debbugs::Packages qw(makesourceversions getversions);
+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::AllUtils qw(min max uniq);
+use DateTime::Format::Pg;
+
+use Carp qw(croak);
 
 BEGIN{
      $VERSION = 1.00;
      $DEBUG = 0 unless defined $DEBUG;
 
      @EXPORT = ();
-     %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy)],
-		     read   => [qw(readbug lockreadbug)],
+     %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
+				qw(isstrongseverity bug_presence split_status_fields),
+				qw(get_bug_statuses),
+			       ],
+		     read   => [qw(readbug read_bug lockreadbug lockreadbugmerge),
+				qw(lock_read_all_merged_bugs),
+			       ],
 		     write  => [qw(writebug makestatus unlockwritebug)],
-		     versions => [qw(addfoundversion addfixedversion),
+		     new => [qw(new_bug)],
+		     versions => [qw(addfoundversions addfixedversions),
+				  qw(removefoundversions removefixedversions)
 				 ],
+		     hook     => [qw(bughook bughook_archive)],
+                     indexdb  => [qw(generate_index_db_line)],
+		     fields   => [qw(%fields)],
 		    );
      @EXPORT_OK = ();
-     Exporter::export_ok_tags(qw(status read write versions));
+     Exporter::export_ok_tags(keys %EXPORT_TAGS);
      $EXPORT_TAGS{all} = [@EXPORT_OK];
 }
 
 
 =head2 readbug
 
-     readbug($bug_number,$location)
+     readbug($bug_num,$location)
+     readbug($bug_num)
 
 Reads a summary file from the archive given a bug number and a bug
 location. Valid locations are those understood by L</getbugcomponent>
 
 =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',
@@ -80,82 +112,332 @@ my %fields = (originator     => 'submitter',
 	      fixed_date     => 'fixed-date',
               blocks         => 'blocks',
               blockedby      => 'blocked-by',
+	      unarchived     => 'unarchived',
+	      summary        => 'summary',
+	      outlook        => 'outlook',
+	      affects        => 'affects',
              );
 
+
 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
 my @rfc1522_fields = qw(originator subject done forwarded owner);
 
-=head2 readbug
+sub readbug {
+     return read_bug(bug => $_[0],
+		     (@_ > 1)?(location => $_[1]):()
+		    );
+}
 
-     readbug($bug_num,$location);
-     readbug($bug_num)
+=head2 read_bug
 
+     read_bug(bug => $bug_num,
+              location => 'archive',
+             );
+     read_bug(summary => 'path/to/bugnum.summary');
+     read_bug($bug_num);
 
-Retreives the information from the summary files for a particular bug
-number. If location is not specified, getbuglocation is called to fill
-it in.
+A more complete function than readbug; it enables you to pass a full
+path to the summary file instead of the bug number and/or location.
 
-=cut
+=head3 Options
 
-# Sesse: ok, that I've moved to Debbugs::Status; I think I'm going to make a variant called read_bug that allows you to just say 
-# read_bug(bugnum=>$nnn); and get back the right thing, or read_bug(path=>$nnn)
-# and then make readbug call read_bug with the right arguments
+=over
 
-sub readbug {
-    my ($lref, $location) = @_;
-    if (not defined $location) {
-	 $location = getbuglocation($lref,'summary');
-	 return undef if not defined $location;
+=item bug -- the bug number
+
+=item location -- optional location which is passed to getbugcomponent
+
+=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<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
+undef on failure, and will die if improper arguments are passed.
+
+=cut
+
+sub read_bug{
+    if (@_ == 1) {
+	 unshift @_, 'bug';
+    }
+    state $spec =
+       {bug => {type => SCALAR,
+		optional => 1,
+		# something really stupid passes negative bugnumbers
+		regex    => qr/^-?\d+/,
+	       },
+	location => {type => SCALAR|UNDEF,
+		     optional => 1,
+		    },
+	summary  => {type => SCALAR,
+		     optional => 1,
+		    },
+	lock     => {type => BOOLEAN,
+		     optional => 1,
+		    },
+	locks    => {type => HASHREF,
+		     optional => 1,
+		    },
+       };
+    my %param = validate_with(params => \@_,
+			      spec   => $spec,
+			     );
+    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;
+    my $report;
+    if (not defined $param{summary}) {
+	 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);
+	 $report    = getbugcomponent($lref, 'report'    , $location);
+	 return undef unless defined $status;
+	 return undef if not -e $status;
+    }
+    else {
+	 $status = $param{summary};
+	 $log = $status;
+	 $report = $status;
+	 $log =~ s/\.summary$/.log/;
+	 $report =~ s/\.summary$/.report/;
+	 ($location) = $status =~ m/(db-h|db|archive)/;
+         ($param{bug}) = $status =~ m/(\d+)\.summary$/;
+    }
+    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 = getbugcomponent($lref, 'summary', $location);
-    return undef unless defined $status;
-    my $status_fh = new IO::File $status, 'r' or
-	 warn "Unable to open $status for reading: $!" and return undef;
+    binmode($status_fh,':encoding(UTF-8)');
 
     my %data;
     my @lines;
-    my $version = 2;
+    my $version;
     local $_;
 
     while (<$status_fh>) {
         chomp;
         push @lines, $_;
-        $version = $1 if /^Format-Version: ([0-9]+)/i;
+	if (not defined $version and
+	    /^Format-Version: ([0-9]+)/i
+	   ) {
+	    $version = $1;
+	}
     }
-
+    $version = 2 if not defined $version;
     # 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;
+    state $namemap = {reverse %fields};
     for my $line (@lines) {
         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{$field} = '' unless exists $data{$field};
+    }
+    if ($version < 3) {
+	for my $field (@rfc1522_fields) {
+	    $data{$field} = decode_rfc1522($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}];
     }
     for my $field (qw(found fixed)) {
+	 # create the found/fixed hashes which indicate when a
+	 # particular version was marked found or marked fixed.
 	 @{$data{$field}}{@{$data{"${field}_versions"}}} =
-	      (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
+	      (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}),
 	       @{$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] // (stat("${log}.gz"))[9];
+    my $report_modified = (stat($report))[9] // $data{log_modified};
+    $data{last_modified} = max($status_modified,$data{log_modified});
+    # if the date isn't set (ancient bug), use the smallest of any of the modified
+    if (not defined $data{date} or not length($data{date})) {
+        $data{date} = min($report_modified,$status_modified,$data{log_modified});
+    }
+    $data{location} = $location;
+    $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
+    $data{bug_num} = $param{bug};
+
+    # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
+    # and not include this bug
+    if (defined $data{mergedwith} and
+       $data{mergedwith}) {
+	$data{mergedwith} =
+	    join(' ',
+		 grep { $_ != $data{bug_num}}
+		 sort { $a <=> $b }
+		 split / /, $data{mergedwith}
+		);
+    }
+    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;
+};
+
+our $sort_and_unique = sub {
+    my @v;
+    my %u;
+    my $all_numeric = 1;
+    for my $v (@_) {
+        if ($all_numeric and $v =~ /\D/) {
+            $all_numeric = 0;
+        }
+        next if exists $u{$v};
+        $u{$v} = 1;
+        push @v, $v;
+    }
+    if ($all_numeric) {
+        return sort {$a <=> $b} @v;
+    } else {
+        return sort @v;
+    }
+};
+
+my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))};
+my %split_fields =
+    (package        => \&splitpackages,
+     affects        => \&splitpackages,
+     # Ideally we won't have to split source, but because some consumers of
+     # get_bug_status cannot handle arrayref, we will split it here.
+     source         => \&splitpackages,
+     blocks         => $ditch_space_unique_and_sort,
+     blockedby      => $ditch_space_unique_and_sort,
+     # 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_space_unique_and_sort,
+     tags           => $ditch_space_unique_and_sort,
+     found_versions => $ditch_space_unique_and_sort,
+     fixed_versions => $ditch_space_unique_and_sort,
+     mergedwith     => $ditch_space_unique_and_sort,
+    );
+
+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)
@@ -170,12 +452,184 @@ See readbug above for information on what this returns
 
 sub lockreadbug {
     my ($lref, $location) = @_;
-    &filelock("lock/$lref");
-    my $data = readbug($lref, $location);
-    &unfilelock unless defined $data;
-    return $data;
+    return read_bug(bug => $lref, location => $location, lock => 1);
+}
+
+=head2 lockreadbugmerge
+
+     my ($locks, $data) = lockreadbugmerge($bug_num,$location);
+
+Performs a filelock, then reads the bug. If the bug is merged, locks
+the merge lock. Returns a list of the number of locks and the bug
+data.
+
+=cut
+
+sub lockreadbugmerge {
+     my $data = lockreadbug(@_);
+     if (not defined $data) {
+	  return (0,undef);
+     }
+     if (not length $data->{mergedwith}) {
+	  return (1,$data);
+     }
+     unfilelock();
+     filelock("$config{spool_dir}/lock/merge");
+     $data = lockreadbug(@_);
+     if (not defined $data) {
+	  unfilelock();
+	  return (0,undef);
+     }
+     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
+        # We do a cmp sort instead of an <=> sort here, because that's
+        # what merge does
+	    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} mergedwith 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);
 
@@ -197,7 +651,7 @@ version.
 
 sub makestatus {
     my ($data,$version) = @_;
-    $version = 2 unless defined $version;
+    $version = 3 unless defined $version;
 
     my $contents = '';
 
@@ -208,10 +662,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} = [split ' ', $newdata{$field}];
-    }
+    %newdata = encode_utf8_structure(%newdata);
 
     if ($version < 3) {
         for my $field (@rfc1522_fields) {
@@ -219,9 +672,16 @@ 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}) {
+            if (exists $newdata{$field} and defined $newdata{$field}) {
                 $contents .= "$newdata{$field}\n";
             } else {
                 $contents .= "\n";
@@ -232,15 +692,16 @@ sub makestatus {
         # further extensibility in the future.
         $contents .= "Format-Version: $version\n";
         for my $field (keys %fields) {
-            if (exists $newdata{$field} and $newdata{$field} ne '') {
+            if (exists $newdata{$field} and defined $newdata{$field}
+		and $newdata{$field} ne '') {
                 # 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;
 }
 
@@ -250,7 +711,7 @@ sub makestatus {
 
 Writes the bug status and summary files out.
 
-Skips writting out a status file if minversion is 2
+Skips writing out a status file if minversion is 2
 
 Does not call bughook if disablebughook is true.
 
@@ -260,21 +721,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
@@ -293,7 +762,7 @@ options mean.
 
 sub unlockwritebug {
     writebug(@_);
-    &unfilelock;
+    unfilelock();
 }
 
 =head1 VERSIONS
@@ -304,7 +773,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
 
@@ -315,11 +784,16 @@ sub addfoundversions {
     my $version = shift;
     my $isbinary = shift;
     return unless defined $version;
-    undef $package if $package =~ m[(?:\s|/)];
+    undef $package if defined $package and $package =~ m[(?:\s|/)];
     my $source = $package;
+    if (defined $package and $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;
@@ -344,44 +818,57 @@ sub addfoundversions {
     }
 }
 
+=head2 removefoundversions
+
+     removefoundversions($data,$package,$versiontoremove)
+
+Removes found versions from $data
+
+If a version is fully qualified (contains /) only versions matching
+exactly are removed. Otherwise, all versions matching the version
+number are removed.
+
+Currently $package and $isbinary are entirely ignored, but accepted
+for backwards compatibility.
+
+=cut
+
 sub removefoundversions {
     my $data = shift;
     my $package = shift;
     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.
-            removefoundversions($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->{found_versions}} =
-            grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
+	 if ($ver =~ m{/}) {
+	      # fully qualified version
+	      @{$data->{found_versions}} =
+		   grep {$_ ne $ver}
+			@{$data->{found_versions}};
+	 }
+	 else {
+	      # non qualified version; delete all matchers
+	      @{$data->{found_versions}} =
+		   grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
+			@{$data->{found_versions}};
+	 }
     }
 }
 
+
 sub addfixedversions {
     my $data = shift;
     my $package = shift;
     my $version = shift;
     my $isbinary = shift;
     return unless defined $version;
-    undef $package if $package =~ m[(?:\s|/)];
+    undef $package if defined $package and $package =~ m[(?:\s|/)];
     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;
@@ -412,24 +899,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}};
+	 }
     }
 }
 
@@ -446,21 +929,21 @@ 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;
 }
 
 
 =head2 bug_archiveable
 
-     bug_archiveable(ref => $bug_num);
+     bug_archiveable(bug => $bug_num);
 
 Options
 
 =over
 
-=item ref -- bug number (required)
+=item bug -- bug number (required)
 
-=item status -- Status hashref (optional)
+=item status -- Status hashref returned by read_bug or get_bug_status (optional)
 
 =item version -- Debbugs::Version information (optional)
 
@@ -472,123 +955,494 @@ Returns 1 if the bug can be archived
 Returns 0 if the bug cannot be archived
 
 If days_until is true, returns the number of days until the bug can be
-archived, -1 if it cannot be archived.
+archived, -1 if it cannot be archived. 0 means that the bug can be
+archived the next time the archiver runs.
+
+Returns undef on failure.
 
 =cut
 
+# This will eventually need to be fixed before we start using mod_perl
+our $version_cache = {};
 sub bug_archiveable{
+     state $spec = {bug => {type => SCALAR,
+			    regex => qr/^\d+$/,
+			   },
+		    status => {type => HASHREF,
+			       optional => 1,
+			      },
+		    days_until => {type => BOOLEAN,
+				   default => 0,
+				  },
+		    ignore_time => {type => BOOLEAN,
+				    default => 0,
+				   },
+		    schema => {type => OBJECT,
+			       optional => 1,
+			      },
+		   };
      my %param = validate_with(params => \@_,
-			       spec   => {ref => {type => SCALAR,
-						  regex => qr/^\d+$/,
-						 },
-					  status => {type => HASHREF,
-						     optional => 1,
-						    },
-					  version => {type => HASHREF,
-						      optional => 1,
-						     },
-					  days_until => {type => BOOLEAN,
-							 default => 0,
-							},
-					 },
+			       spec   => $spec,
 			      );
+     # This is what we return if the bug cannot be archived.
+     my $cannot_archive = $param{days_until}?-1:0;
      # read the status information
-     # read the version information
+     my $status = $param{status};
+     if (not exists $param{status} or not defined $status) {
+	  $status = read_bug(bug=>$param{bug});
+	  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
-     # 2. Fixed in unstable if tagged unstable
-     # 3. Fixed in stable if tagged stable
-     # 4. Fixed in testing if tagged testing
-     # 5. Fixed in experimental if tagged experimental
+     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 or not -e $log_file) {
+	  print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
+	  return $cannot_archive;
+     }
+     my @log_files = $log_file, (map {my $log = getbugcomponent($_,'log');
+					   defined $log ? ($log) : ();
+				      }
+			   split / /, $status->{mergedwith});
+     my $max_log_age = max(map {-e $_?($config{remove_age} - -M _):0}
+			   @log_files);
+     if (not $param{days_until} and not $param{ignore_time}
+	 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.
+     # We examine the set of distribution tags. If a bug has no distribution
+     # 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;
+     my $min_archive_days = 0;
+     if (@{$status->{fixed_versions}}) {
+	  my %dist_tags;
+	  @dist_tags{@{$config{removal_distribution_tags}}} =
+	       (1) x @{$config{removal_distribution_tags}};
+	  my %dists;
+	  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},
+					    dist => [keys %dists],
+					    source => 1,
+					    hash_slice(%param,'schema'),
+					   );
+	  @source_versions{@sourceversions} = (1) x @sourceversions;
+	  # If the bug has not been fixed in the versions actually
+	  # distributed, then it cannot be archived.
+	  if ('found' eq max_buggy(bug => $param{bug},
+				   sourceversions => [keys %source_versions],
+				   found          => $status->{found_versions},
+				   fixed          => $status->{fixed_versions},
+				   version_cache  => $version_cache,
+				   package        => $status->{package},
+				   hash_slice(%param,'schema'),
+				  )) {
+	       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
+	  # that matters, we check to see how long it has been fixed.
+
+	  # If $param{ignore_time}, then we should ignore time.
+	  if ($param{ignore_time}) {
+	       return $param{days_until}?0:1;
+	  }
+
+	  # To do this, we order the times from most recent to oldest;
+	  # when we come to the first found version, we stop.
+	  # If we run out of versions, we only report the time of the
+	  # last one.
+	  my %time_versions = get_versions(package => $status->{package},
+					   dist    => [keys %dists],
+					   source  => 1,
+					   time    => 1,
+					   hash_slice(%param,'schema'),
+					  );
+	  for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
+	       my $buggy = buggy(bug => $param{bug},
+				 version        => $version,
+				 found          => $status->{found_versions},
+				 fixed          => $status->{fixed_versions},
+				 version_cache  => $version_cache,
+				 package        => $status->{package},
+				 hash_slice(%param,'schema'),
+				);
+	       last if $buggy eq 'found';
+	       $min_fixed_time = min($time_versions{$version},$min_fixed_time);
+	  }
+	  $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($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 {
+	  return $param{days_until}?0:1;
+     }
 }
 
-=head1 PRIVATE FUNCTIONS
 
-=cut
+=head2 get_bug_status
 
-sub update_realtime {
-	my ($file, $bug, $new) = @_;
+     my $status = get_bug_status(bug => $nnn);
 
-	# update realtime index.db
+     my $status = get_bug_status($bug_num)
 
-	open(IDXDB, "<$file") or die "Couldn't open $file";
-	open(IDXNEW, ">$file.new");
+=head3 Options
 
-	my $line;
-	my @line;
-	while($line = <IDXDB>) {
-		@line = split /\s/, $line;
-		last if ($line[1] >= $bug);
-		print IDXNEW $line;
-		$line = "";
-	}
+=over
 
-	if ($new eq "NOCHANGE") {
-		print IDXNEW $line if ($line ne "" && $line[1] == $bug);
-	} elsif ($new eq "REMOVE") {
-		0;
-	} else {
-		print IDXNEW $new;
-	}
-	if ($line ne "" && $line[1] > $bug) {
-		print IDXNEW $line;
-		$line = "";
-	}
+=item bug -- scalar bug number
 
-	print IDXNEW while(<IDXDB>);
+=item status -- optional hashref of bug status as returned by readbug
+(can be passed to avoid rereading the bug information)
 
-	close(IDXNEW);
-	close(IDXDB);
+=item bug_index -- optional tied index of bug status infomration;
+currently not correctly implemented.
 
-	rename("$file.new", $file);
+=item version -- optional version(s) to check package status at
 
-	return $line;
-}
+=item dist -- optional distribution(s) to check package status at
 
-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");
-	update_realtime("$config{spool_dir}/index.archive.realtime",
-		$ref, $line);
-	&unfilelock;
-}	
+=item arch -- optional architecture(s) to check package status at
 
-sub bughook {
-	my ( $type, $ref, $data ) = @_;
-	&filelock("debbugs.trace.lock");
+=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
+changed before using this function in long lived programs.
+
+=head3 Returns
+
+Currently returns a hashref of status with the following keys.
+
+=over
+
+=item id -- bug number
+
+=item bug_num -- duplicate of id
+
+=item keywords -- tags set on the bug, including usertags if bugusertags passed.
+
+=item tags -- duplicate of keywords
+
+=item package -- name of package that the bug is assigned to
+
+=item severity -- severity of the bug
+
+=item pending -- pending state of the bug; one of following possible
+values; values listed later have precedence if multiple conditions are
+satisifed:
+
+=over
+
+=item pending -- default state
+
+=item forwarded -- bug has been forwarded
+
+=item pending-fixed -- bug is tagged pending
+
+=item fixed -- bug is tagged fixed
+
+=item absent -- bug does not apply to this distribution/architecture
+
+=item done -- bug is resolved in this distribution/architecture
+
+=back
+
+=item location -- db-h or archive; the location in the filesystem
+
+=item subject -- title of the bug
+
+=item last_modified -- epoch that the bug was last modified
 
-	&appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
+=item date -- epoch that the bug was filed
 
-	my $whendone = "open";
-	my $severity = $config{default_severity};
-	(my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
-	$pkglist =~ s/^,+//;
-	$pkglist =~ s/,+$//;
-	$whendone = "forwarded" if length $data->{forwarded};
-	$whendone = "done" if length $data->{done};
-	$severity = $data->{severity} if length $data->{severity};
+=item originator -- bug reporter
 
-	my $k = sprintf "%s %d %d %s [%s] %s %s\n",
-			$pkglist, $ref, $data->{date}, $whendone,
-			$data->{originator}, $severity, $data->{keywords};
+=item log_modified -- epoch that the log file was last modified
 
-	update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);
+=item msgid -- Message id of the original bug report
 
-	&unfilelock;
+=back
+
+
+Other key/value pairs are returned but are not currently documented here.
+
+=cut
+
+sub get_bug_status {
+     if (@_ == 1) {
+	  unshift @_, 'bug';
+     }
+     state $spec =
+	{bug       => {type => SCALAR,
+		       regex => qr/^\d+$/,
+		      },
+	 status    => {type => HASHREF,
+		       optional => 1,
+		      },
+	 bug_index => {type => OBJECT,
+		       optional => 1,
+		      },
+	 version   => {type => SCALAR|ARRAYREF,
+		       optional => 1,
+		      },
+	 dist       => {type => SCALAR|ARRAYREF,
+			optional => 1,
+		       },
+	 arch       => {type => SCALAR|ARRAYREF,
+			optional => 1,
+		       },
+	 bugusertags   => {type => HASHREF,
+			   optional => 1,
+			  },
+	 sourceversions => {type => ARRAYREF,
+			    optional => 1,
+			   },
+	 indicatesource => {type => BOOLEAN,
+			    default => 1,
+			   },
+	 binary_to_source_cache => {type => HASHREF,
+				    optional => 1,
+				   },
+	 schema => {type => OBJECT,
+		    optional => 1,
+		   },
+	};
+     my %param = validate_with(params => \@_,
+			       spec   => $spec,
+			      );
+     my %status;
+
+     if (defined $param{bug_index} and
+	 exists $param{bug_index}{$param{bug}}) {
+	 %status = %{ $param{bug_index}{$param{bug}} };
+	 $status{pending} = $status{ status };
+	 $status{id} = $param{bug};
+	 return \%status;
+     }
+     my $statuses = get_bug_statuses(@_);
+     if (exists $statuses->{$param{bug}}) {
+	 return $statuses->{$param{bug}};
+     } else {
+	return {};
+     }
 }
 
+sub get_bug_statuses {
+     state $spec =
+	{bug       => {type => SCALAR|ARRAYREF,
+		      },
+	 status    => {type => HASHREF,
+		       optional => 1,
+		      },
+	 bug_index => {type => OBJECT,
+		       optional => 1,
+		      },
+	 version   => {type => SCALAR|ARRAYREF,
+		       optional => 1,
+		      },
+	 dist       => {type => SCALAR|ARRAYREF,
+			optional => 1,
+		       },
+	 arch       => {type => SCALAR|ARRAYREF,
+			optional => 1,
+		       },
+	 bugusertags   => {type => HASHREF,
+			   optional => 1,
+			  },
+	 sourceversions => {type => ARRAYREF,
+			    optional => 1,
+			   },
+	 indicatesource => {type => BOOLEAN,
+			    default => 1,
+			   },
+	 binary_to_source_cache => {type => HASHREF,
+				    optional => 1,
+				   },
+	 schema => {type => OBJECT,
+		    optional => 1,
+		   },
+	};
+     my %param = validate_with(params => \@_,
+			       spec   => $spec,
+			      );
+     my $bin_to_src_cache = {};
+     if (defined $param{binary_to_source_cache}) {
+	 $bin_to_src_cache = $param{binary_to_source_cache};
+     }
+     my %status;
+     my %statuses;
+     if (defined $param{schema}) {
+	 my @bug_statuses =
+	     $param{schema}->resultset('BugStatus')->
+	     search_rs({id => [make_list($param{bug})]},
+		       {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->
+			   all();
+	 for my $bug_status (@bug_statuses) {
+	     $statuses{$bug_status->{bug_num}} =
+		 $bug_status;
+	     for my $field (qw(blocks blockedby done),
+			    qw(tags mergedwith affects)
+			   ) {
+		 $bug_status->{$field} //='';
+	     }
+	     $bug_status->{keywords} =
+		 $bug_status->{tags};
+	     $bug_status->{location} = $bug_status->{archived}?'archive':'db-h';
+	     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
+		 $bug_status->{$field} = [split ' ', $bug_status->{$field} // ''];
+	     }
+	     for my $field (qw(found fixed)) {
+		 # create the found/fixed hashes which indicate when a
+		 # particular version was marked found or marked fixed.
+		 @{$bug_status->{$field}}{@{$bug_status->{"${field}_versions"}}} =
+		     (('') x (@{$bug_status->{"${field}_versions"}} -
+			      @{$bug_status->{"${field}_date"}}),
+		      @{$bug_status->{"${field}_date"}});
+	     }
+	     $bug_status->{id} = $bug_status->{bug_num};
+	 }
+     } else {
+	 for my $bug (make_list($param{bug})) {
+	     if (defined $param{bug_index} and
+		 exists $param{bug_index}{$bug}) {
+		 my %status = %{$param{bug_index}{$bug}};
+		 $status{pending} = $status{status};
+		 $status{id} = $bug;
+		 $statuses{$bug} = \%status;
+	     }
+	     elsif (defined $param{status} and
+		    $param{status}{bug_num} == $bug
+		   ) {
+		 $statuses{$bug} = {%{$param{status}}};
+	     } else {
+		 my $location = getbuglocation($bug, 'summary');
+		 next if not defined $location or not length $location;
+		 my %status = %{ readbug( $bug, $location ) };
+		 $status{id} = $bug;
+		 $statuses{$bug} = \%status;
+	     }
+	 }
+     }
+     for my $bug (keys %statuses) {
+	 my $status = $statuses{$bug};
 
-=head2 get_bug_status
+	 if (defined $param{bugusertags}{$param{bug}}) {
+	     $status->{keywords} = "" unless defined $status->{keywords};
+	     $status->{keywords} .= " " unless $status->{keywords} eq "";
+	     $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,
+					      cache => $bin_to_src_cache,
+					      defined $param{schema}?
+					      (schema => $param{schema}):(),
+					     );
+
+	 $status->{"package"} = 'unknown' if ($status->{"package"} eq '');
+	 $status->{"severity"} = 'normal' if (not defined $status->{severity} or $status->{"severity"} eq '');
+
+	 $status->{"pending"} = 'pending';
+	 $status->{"pending"} = 'forwarded'	    if (length($status->{"forwarded"}));
+	 $status->{"pending"} = 'pending-fixed'    if ($tags{pending});
+	 $status->{"pending"} = 'fixed'	    if ($tags{fixed});
+
+
+	 my $presence = bug_presence(status => $status,
+				     bug => $bug,
+				     map{(exists $param{$_})?($_,$param{$_}):()}
+				     qw(sourceversions arch dist version found fixed package)
+				    );
+	 if (defined $presence) {
+	     if ($presence eq 'fixed') {
+		 $status->{pending} = 'done';
+	     } elsif ($presence eq 'absent') {
+		 $status->{pending} = 'absent';
+	     }
+	 }
+     }
+     return \%statuses;
+}
 
-     my $status = get_bug_status(bug => $nnn);
+=head2 bug_presence
+
+     my $precence = bug_presence(bug => nnn,
+                                 ...
+                                );
+
+Returns 'found', 'absent', 'fixed' or undef based on whether the bug
+is found, absent, fixed, or no information is available in the
+distribution (dist) and/or architecture (arch) specified.
 
-     my $status = get_bug_status($bug_num)
 
 =head3 Options
 
@@ -608,25 +1462,15 @@ currently not correctly implemented.
 
 =item arch -- optional architecture to check package status at
 
-=item usertags -- optional hashref of usertags
-
 =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.
 
 =back
 
-Note: Currently the version information is cached; this needs to be
-changed before using this function in long lived programs.
-
 =cut
 
-# This will eventually need to be fixed before we start using mod_perl
-my $version_cache = {};
-sub get_bug_status {
-     if (@_ == 1) {
-	  unshift @_, 'bug';
-     }
+sub bug_presence {
      my %param = validate_with(params => \@_,
 			       spec   => {bug       => {type => SCALAR,
 							regex => qr/^\d+$/,
@@ -634,19 +1478,13 @@ sub get_bug_status {
 					  status    => {type => HASHREF,
 						        optional => 1,
 						       },
-					  bug_index => {type => OBJECT,
-							optional => 1,
-						       },
-					  version   => {type => SCALAR,
+					  version   => {type => SCALAR|ARRAYREF,
 							optional => 1,
 						       },
-					  dist       => {type => SCALAR,
+					  dist       => {type => SCALAR|ARRAYREF,
 							 optional => 1,
 							},
-					  arch       => {type => SCALAR,
-							 optional => 1,
-							},
-					  usertags   => {type => HASHREF,
+					  arch       => {type => SCALAR|ARRAYREF,
 							 optional => 1,
 							},
 					  sourceversions => {type => ARRAYREF,
@@ -655,94 +1493,193 @@ sub get_bug_status {
 					 },
 			      );
      my %status;
-
-     if (defined $param{bug_index} and
-	 exists $param{bug_index}{$param{bug}}) {
-	  %status = %{ $param{bug_index}{$param{bug}} };
-	  $status{pending} = $status{ status };
-	  $status{id} = $param{bug};
-	  return \%status;
-     }
      if (defined $param{status}) {
-	  %status = %{$param{status}};
+	 %status = %{$param{status}};
      }
      else {
 	  my $location = getbuglocation($param{bug}, 'summary');
 	  return {} if not length $location;
 	  %status = %{ readbug( $param{bug}, $location ) };
      }
-     $status{id} = $param{bug};
-
-     if (defined $param{usertags}{$param{bug}}) {
-	  $status{keywords} = "" unless defined $status{keywords};
-	  $status{keywords} .= " " unless $status{keywords} eq "";
-	  $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}});
-     }
-     $status{tags} = $status{keywords};
-     my %tags = map { $_ => 1 } split ' ', $status{tags};
-
-     $status{"package"} =~ s/\s*$//;
-     $status{"package"} = 'unknown' if ($status{"package"} eq '');
-     $status{"severity"} = 'normal' if ($status{"severity"} eq '');
-
-     $status{"pending"} = 'pending';
-     $status{"pending"} = 'forwarded'	    if (length($status{"forwarded"}));
-     $status{"pending"} = 'pending-fixed'    if ($tags{pending});
-     $status{"pending"} = 'fixed'	    if ($tags{fixed});
 
      my @sourceversions;
+     my $pseudo_desc = getpseudodesc();
      if (not exists $param{sourceversions}) {
-	  my @versions;
-	  if (defined $param{version}) {
-	       @versions = ($param{version});
+	  my %sourceversions;
+	  # 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})) {
+		    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}) {
-	       @versions = getversions($status{package}, $param{dist}, $param{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;
+		    }
+	       }
+	       # 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.
-	  @sourceversions = makesourceversions($status{package},
-					       $param{arch},
-					       @versions);
+	  # DLA: src= queries should just pass arch=source, and they'll be happy.
+	  @sourceversions = keys %sourceversions;
      }
      else {
 	  @sourceversions = @{$param{sourceversions}};
      }
-
+     my $maxbuggy = 'undef';
      if (@sourceversions) {
-	  # Resolve bugginess states (we might be looking at multiple
-	  # architectures, say). Found wins, then fixed, then absent.
-	  my $maxbuggy = 'absent';
-	  for my $version (@sourceversions) {
+	  $maxbuggy = max_buggy(bug => $param{bug},
+				sourceversions => \@sourceversions,
+				found => $status{found_versions},
+				fixed => $status{fixed_versions},
+				package => $status{package},
+				version_cache => $version_cache,
+			       );
+     }
+     elsif (defined $param{dist} and
+	    not exists $pseudo_desc->{$status{package}}) {
+	  return 'absent';
+     }
+     if (length($status{done}) and
+	 (not @sourceversions or not @{$status{fixed_versions}})) {
+	  return 'fixed';
+     }
+     return $maxbuggy;
+}
+
+
+=head2 max_buggy
+
+     max_buggy()
+
+=head3 Options
+
+=over
+
+=item bug -- scalar bug number
+
+=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.
+
+=back
+
+Note: Currently the version information is cached; this needs to be
+changed before using this function in long lived programs.
+
+
+=cut
+sub max_buggy{
+     my %param = validate_with(params => \@_,
+			       spec   => {bug       => {type => SCALAR,
+							regex => qr/^\d+$/,
+						       },
+					  sourceversions => {type => ARRAYREF,
+							     default => [],
+							    },
+					  found          => {type => ARRAYREF,
+							     default => [],
+							    },
+					  fixed          => {type => ARRAYREF,
+							     default => [],
+							    },
+					  package        => {type => SCALAR,
+							    },
+					  version_cache  => {type => HASHREF,
+							     default => {},
+							    },
+					  schema => {type => OBJECT,
+						     optional => 1,
+						    },
+					 },
+			      );
+     # Resolve bugginess states (we might be looking at multiple
+     # architectures, say). Found wins, then fixed, then absent.
+     my $maxbuggy = 'absent';
+     for my $package (split /\s*,\s*/, $param{package}) {
+	  for my $version (@{$param{sourceversions}}) {
 	       my $buggy = buggy(bug => $param{bug},
 				 version => $version,
-				 found => $status{found_versions},
-				 fixed => $status{fixed_versions},
-				 version_cache => $version_cache,
-				 package => $status{package},
+				 found => $param{found},
+				 fixed => $param{fixed},
+				 version_cache => $param{version_cache},
+				 package => $package,
 				);
 	       if ($buggy eq 'found') {
-		    $maxbuggy = 'found';
-		    last;
-	       } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
+		    return 'found';
+	       } elsif ($buggy eq 'fixed') {
 		    $maxbuggy = 'fixed';
 	       }
 	  }
-	  if ($maxbuggy eq 'absent') {
-	       $status{"pending"} = 'absent';
-	  } elsif ($maxbuggy eq 'fixed') {
-	       $status{"pending"} = 'done';
-	  }
      }
-
-     if (length($status{done}) and
-	 (not @sourceversions or not @{$status{fixed_versions}})) {
-	  $status{"pending"} = 'done';
-     }
-
-     return \%status;
+     return $maxbuggy;
 }
 
+
 =head2 buggy
 
      buggy(bug => nnn,
@@ -780,6 +1717,9 @@ sub buggy {
 						     },
 					  version => {type => SCALAR,
 						     },
+					  schema => {type => OBJECT,
+						     optional => 1,
+						    },
 					 },
 			      );
      my @found = @{$param{found}};
@@ -794,22 +1734,33 @@ 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';
+	       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 @maint = package_maintainer(source => $source,
+						  hash_slice(%param,'schema'),
+						 );
+		    next unless @maint;
+		    warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
+		    next;
+	       }
 	       $version->load($version_fh);
 	  }
 	  if (defined $param{version_cache}) {
@@ -822,6 +1773,135 @@ sub buggy {
      return $version->buggy($param{version},\@found,\@fixed);
 }
 
+sub isstrongseverity {
+    my $severity = shift;
+    $severity = $config{default_severity} if
+	 not defined $severity or $severity eq '';
+    return grep { $_ eq $severity } @{$config{strong_severities}};
+}
+
+=head1 indexdb
+
+=head2 generate_index_db_line
+
+      	my $data = read_bug(bug => $bug,
+			    location => $initialdir);
+        # generate_index_db_line hasn't been written yet at all.
+        my $line = generate_index_db_line($data);
+
+Returns a line for a bug suitable to be written out to index.db.
+
+=cut
+
+sub generate_index_db_line {
+    my ($data,$bug) = @_;
+
+    # just in case someone has given us a split out data
+    $data = join_status_fields($data);
+
+    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};
+    return sprintf "%s %d %d %s [%s] %s %s\n",
+        $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
+            $data->{originator}, $severity, $data->{keywords};
+}
+
+
+
+=head1 PRIVATE FUNCTIONS
+
+=cut
+
+sub update_realtime {
+	my ($file, %bugs) = @_;
+
+	# update realtime index.db
+
+	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: $!";
+
+        binmode($idx_old,':raw:utf8');
+        binmode($idx_new,':raw:encoding(UTF-8)');
+	my $min_bug = min(keys %bugs);
+	my $line;
+	my @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 {$idx_new} <$idx_old>;
+
+	close($idx_new);
+	close($idx_old);
+
+	rename("$file.new", $file);
+
+	return %changed_bugs;
+}
+
+sub bughook_archive {
+	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",
+			%bugs);
+	unfilelock();
+}
+
+sub bughook {
+	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));
+
+	     $bugs{$bug} = generate_index_db_line($data,$bug);
+	}
+	update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
+
+	unfilelock();
+}
+
 
 1;