X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FPackages.pm;h=2cdef213fce3b89abec6349e5e909d1166fb97a7;hb=cd0b9752cb6b5cec796baf1c07951cee5971b42e;hp=5284e2c58f2aeecd459f32f75d96fd4a11f4efd2;hpb=70cf77464dc1d0966e821892d73b2dd6d1babc70;p=debbugs.git

diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm
index 5284e2c..2cdef21 100644
--- a/Debbugs/Packages.pm
+++ b/Debbugs/Packages.pm
@@ -1,20 +1,32 @@
+# 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 by Don Armstrong <don@donarmstrong.com>.
+
 package Debbugs::Packages;
 
 use warnings;
 use strict;
 
-use Debbugs::Config qw(:config :globals);
-
-use base qw(Exporter);
+use Exporter qw(import);
 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
 
+use Carp;
+
+use Debbugs::Config qw(:config :globals);
+
 BEGIN {
     $VERSION = 1.00;
 
      @EXPORT = ();
-     %EXPORT_TAGS = (versions => [qw(getversions)],
+     %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
 		     mapping  => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
-				  qw(binarytosource sourcetobinary makesourceversions)
+				  qw(binary_to_source sourcetobinary makesourceversions),
+				  qw(source_to_binary),
 				 ],
 		    );
      @EXPORT_OK = ();
@@ -25,6 +37,12 @@ BEGIN {
 use Fcntl qw(O_RDONLY);
 use MLDBM qw(DB_File Storable);
 use Storable qw(dclone);
+use Params::Validate qw(validate_with :types);
+use Debbugs::Common qw(make_list globify_scalar sort_versions);
+use DateTime::Format::Pg;
+use List::AllUtils qw(min max uniq);
+
+use IO::File;
 
 $MLDBM::DumpMeth = 'portable';
 $MLDBM::RemoveTaint = 1;
@@ -43,43 +61,42 @@ may not make sense in other contexts.)
 
 =head1 METHODS
 
-=over 8
-
-=item getpkgsrc
+=head2 getpkgsrc
 
 Returns a reference to a hash of binary package names to their corresponding
 source package names.
 
 =cut
 
-my $_pkgsrc;
-my $_pkgcomponent;
-my $_srcpkg;
+our $_pkgsrc;
+our $_pkgcomponent;
+our $_srcpkg;
 sub getpkgsrc {
     return $_pkgsrc if $_pkgsrc;
-    return {} unless defined $Debbugs::Packages::gPackageSource;
+    return {} unless defined $config{package_source} and
+	length $config{package_source};
     my %pkgsrc;
     my %pkgcomponent;
     my %srcpkg;
 
-    open(MM,"$Debbugs::Packages::gPackageSource")
-	or die("open $Debbugs::Packages::gPackageSource: $!");
-    while(<MM>) {
+    my $fh = IO::File->new($config{package_source},'r')
+	or croak("Unable to open $config{package_source} for reading: $!");
+    while(<$fh>) {
 	next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
 	my ($bin,$cmp,$src)=($1,$2,$3);
-	$bin =~ y/A-Z/a-z/;
+	$bin = lc($bin);
 	$pkgsrc{$bin}= $src;
 	push @{$srcpkg{$src}}, $bin;
 	$pkgcomponent{$bin}= $cmp;
     }
-    close(MM);
+    close($fh);
     $_pkgsrc = \%pkgsrc;
     $_pkgcomponent = \%pkgcomponent;
     $_srcpkg = \%srcpkg;
     return $_pkgsrc;
 }
 
-=item getpkgcomponent
+=head2 getpkgcomponent
 
 Returns a reference to a hash of binary package names to the component of
 the archive containing those binary packages (e.g. "main", "contrib",
@@ -93,7 +110,7 @@ sub getpkgcomponent {
     return $_pkgcomponent;
 }
 
-=item getsrcpkgs
+=head2 getsrcpkgs
 
 Returns a list of the binary packages produced by a given source package.
 
@@ -106,63 +123,503 @@ sub getsrcpkgs {
     return @{$_srcpkg->{$src}};
 }
 
-=item binarytosource
+=head2 binary_to_source
+
+     binary_to_source(package => 'foo',
+                      version => '1.2.3',
+                      arch    => 'i386');
+
+
+Turn a binary package (at optional version in optional architecture)
+into a single (or set) of source packages (optionally) with associated
+versions.
+
+By default, in LIST context, returns a LIST of array refs of source
+package, source version pairs corresponding to the binary package(s),
+arch(s), and verion(s) passed.
+
+In SCALAR context, only the corresponding source packages are
+returned, concatenated with ', ' if necessary.
+
+If no source can be found, returns undef in scalar context, or the
+empty list in list context.
+
+=over
+
+=item binary -- binary package name(s) as a SCALAR or ARRAYREF
+
+=item version -- binary package version(s) as a SCALAR or ARRAYREF;
+optional, defaults to all versions.
+
+=item arch -- binary package architecture(s) as a SCALAR or ARRAYREF;
+optional, defaults to all architectures.
+
+=item source_only -- return only the source name (forced on if in
+SCALAR context), defaults to false.
+
+=item scalar_only -- return a scalar only (forced true if in SCALAR
+context, also causes source_only to be true), defaults to false.
 
-Returns a reference to the source package name and version pair
-corresponding to a given binary package name, version, and architecture. If
-undef is passed as the architecture, returns a list of references to all
-possible pairs of source package names and versions for all architectures,
-with any duplicates removed.
+=item cache -- optional HASHREF to be used to cache results of
+binary_to_source.
+
+=back
 
 =cut
 
-my %_binarytosource;
-sub binarytosource {
-    my ($binname, $binver, $binarch) = @_;
+# the two global variables below are used to tie the source maps; we
+# probably should be retying them in long lived processes.
+our %_binarytosource;
+sub _tie_binarytosource {
+    if (not tied %_binarytosource) {
+	tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
+	    die "Unable to open $config{binary_source_map} for reading";
+    }
+}
+our %_sourcetobinary;
+sub _tie_sourcetobinary {
+    if (not tied %_sourcetobinary) {
+	tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
+	    die "Unable to open $config{source_binary_map} for reading";
+    }
+}
+sub binary_to_source{
+    my %param = validate_with(params => \@_,
+			      spec   => {binary => {type => SCALAR|ARRAYREF,
+						    },
+					 version => {type => SCALAR|ARRAYREF,
+						     optional => 1,
+						    },
+					 arch    => {type => SCALAR|ARRAYREF,
+						     optional => 1,
+						    },
+					 source_only => {default => 0,
+							},
+					 scalar_only => {default => 0,
+							},
+					 cache => {type => HASHREF,
+						   default => {},
+						  },
+					 schema => {type => OBJECT,
+						    optional => 1,
+						   },
+					},
+			     );
 
     # TODO: This gets hit a lot, especially from buggyversion() - probably
     # need an extra cache for speed here.
-    return () unless defined $gBinarySourceMap;
+    return () unless defined $gBinarySourceMap or defined $param{schema};
+
+    if ($param{scalar_only} or not wantarray) {
+	$param{source_only} = 1;
+	$param{scalar_only} = 1;
+    }
 
-    if (tied %_binarytosource or
-	    tie %_binarytosource, 'MLDBM',
-		$gBinarySourceMap, O_RDONLY) {
+    my @source;
+    my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]);
+    my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
+    my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
+    return () unless @binaries;
+
+    my $cache_key = join("\1",
+			 join("\0",@binaries),
+			 join("\0",@versions),
+			 join("\0",@archs),
+			 join("\0",@param{qw(source_only scalar_only)}));
+    if (exists $param{cache}{$cache_key}) {
+	return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
+	    @{$param{cache}{$cache_key}};
+    }
+    # any src:foo is source package foo with unspecified version
+    @source = map {/^src:(.+)$/?
+		       [$1,'']:()} @binaries;
+    @binaries = grep {$_ !~ /^src:/} @binaries;
+    if ($param{schema}) {
+	if ($param{source_only}) {
+	    @source = map {$_->[0]} @source;
+	    my $src_rs = $param{schema}->resultset('SrcPkg')->
+		search_rs({'bin_pkg.pkg' => [@binaries],
+			   @versions?('bin_vers.ver'    => [@versions]):(),
+			   @archs?('arch.arch' => [@archs]):(),
+			  },
+			 {join => {'src_vers'=>
+				  {'bin_vers'=> ['arch','bin_pkg']}
+				  },
+			  columns => [qw(pkg)],
+			  order_by => [qw(pkg)],
+			  result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+			  distinct => 1,
+			 },
+			 );
+	    push @source,
+		map {$_->{pkg}} $src_rs->all;
+	    if ($param{scalar_only}) {
+		@source = join(',',@source);
+	    }
+	    $param{cache}{$cache_key} = \@source;
+	    return $param{scalar_only}?$source[0]:@source;
+	}
+	my $src_rs = $param{schema}->resultset('SrcVer')->
+	    search_rs({'bin_pkg.pkg' => [@binaries],
+		       @versions?('bin_vers.ver' => [@versions]):(),
+		       @archs?('arch.arch' => [@archs]):(),
+		      },
+		     {join => ['src_pkg',
+			      {'bin_vers' => ['arch','binpkg']},
+			      ],
+		      columns => ['src_pkg.pkg','src_ver.ver'],
+		      result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+		      order_by => ['src_pkg.pkg','src_ver.ver'],
+		      distinct => 1,
+		     },
+		     );
+	push @source,
+	    map {[$_->{src_pkg}{pkg},
+		  $_->{src_ver}{ver},
+		 ]} $src_rs->all;
+	if (not @source and not @versions and not @archs) {
+	    $src_rs = $param{schema}->resultset('SrcPkg')->
+		search_rs({pkg => [@binaries]},
+			 {join => ['src_vers'],
+			  columns => ['src_pkg.pkg','src_vers.ver'],
+			  distinct => 1,
+			 },
+			 );
+	    push @source,
+	    map {[$_->{src_pkg}{pkg},
+		  $_->{src_vers}{ver},
+		 ]} $src_rs->all;
+	}
+	$param{cache}{$cache_key} = \@source;
+	return $param{scalar_only}?$source[0]:@source;
+    }
+    for my $binary (@binaries) {
+	_tie_binarytosource;
 	# avoid autovivification
-	my $binary = $_binarytosource{$binname};
-	return () unless defined $binary;
-	my %binary = %{$binary};
-	if (exists $binary{$binver}) {
-	    if (defined $binarch) {
-		my $src = $binary{$binver}{$binarch};
-		return () unless defined $src; # not on this arch
-		# Copy the data to avoid tiedness problems.
-		return dclone($src);
-	    } else {
-		# Get (srcname, srcver) pairs for all architectures and
-		# remove any duplicates. This involves some slightly tricky
-		# multidimensional hashing; sorry. Fortunately there'll
-		# usually only be one pair returned.
-		my %uniq;
-		for my $ar (keys %{$binary{$binver}}) {
-		    my $src = $binary{$binver}{$ar};
+	my $bin = $_binarytosource{$binary};
+	next unless defined $bin;
+	if (not @versions) {
+	    for my $ver (keys %{$bin}) {
+		for my $ar (keys %{$bin->{$ver}}) {
+		    my $src = $bin->{$ver}{$ar};
 		    next unless defined $src;
-		    $uniq{$src->[0]}{$src->[1]} = 1;
+		    push @source,[$src->[0],$src->[1]];
+		}
+	    }
+	}
+	else {
+	    for my $version (@versions) {
+		next unless exists $bin->{$version};
+		if (exists $bin->{$version}{all}) {
+		    push @source,dclone($bin->{$version}{all});
+		    next;
+		}
+		my @t_archs;
+		if (@archs) {
+		    @t_archs = @archs;
+		}
+		else {
+		    @t_archs = keys %{$bin->{$version}};
 		}
-		my @uniq;
-		for my $sn (sort keys %uniq) {
-		    push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
+		for my $arch (@t_archs) {
+		    push @source,dclone($bin->{$version}{$arch}) if
+			exists $bin->{$version}{$arch};
 		}
-		return @uniq;
 	    }
 	}
     }
 
+    if (not @source and not @versions and not @archs) {
+	# ok, we haven't found any results at all. If we weren't given
+	# a specific version and architecture, then we should try
+	# really hard to figure out the right source
+
+	# if any the packages we've been given are a valid source
+	# package name, and there's no binary of the same name (we got
+	# here, so there isn't), return it.
+	_tie_sourcetobinary();
+	for my $maybe_sourcepkg (@binaries) {
+	    if (exists $_sourcetobinary{$maybe_sourcepkg}) {
+		push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}};
+	    }
+	}
+	# if @source is still empty here, it's probably a non-existant
+	# source package, so don't return anything.
+    }
+
+    my @result;
+
+    if ($param{source_only}) {
+	my %uniq;
+	for my $s (@source) {
+	    # we shouldn't need to do this, but do this temporarily to
+	    # stop the warning.
+	    next unless defined $s->[0];
+	    $uniq{$s->[0]} = 1;
+	}
+	@result = sort keys %uniq;
+	if ($param{scalar_only}) {
+	    @result = join(', ',@result);
+	}
+    }
+    else {
+	my %uniq;
+	for my $s (@source) {
+	    $uniq{$s->[0]}{$s->[1]} = 1;
+	}
+	for my $sn (sort keys %uniq) {
+	    push @result, [$sn, $_] for sort keys %{$uniq{$sn}};
+	}
+    }
+
     # No $gBinarySourceMap, or it didn't have an entry for this name and
     # version.
-    return ();
+    $param{cache}{$cache_key} = \@result;
+    return $param{scalar_only} ? $result[0] : @result;
 }
 
-=item sourcetobinary
+=head2 source_to_binary
+
+     source_to_binary(package => 'foo',
+                      version => '1.2.3',
+                      arch    => 'i386');
+
+
+Turn a source package (at optional version) into a single (or set) of all binary
+packages (optionally) with associated versions.
+
+By default, in LIST context, returns a LIST of array refs of binary package,
+binary version, architecture triples corresponding to the source package(s) and
+verion(s) passed.
+
+In SCALAR context, only the corresponding binary packages are returned,
+concatenated with ', ' if necessary.
+
+If no binaries can be found, returns undef in scalar context, or the
+empty list in list context.
+
+=over
+
+=item source -- source package name(s) as a SCALAR or ARRAYREF
+
+=item version -- binary package version(s) as a SCALAR or ARRAYREF;
+optional, defaults to all versions.
+
+=item dist -- list of distributions to return corresponding binary packages for
+as a SCALAR or ARRAYREF.
+
+=item binary_only -- return only the source name (forced on if in SCALAR
+context), defaults to false. [If in LIST context, returns a list of binary
+names.]
+
+=item scalar_only -- return a scalar only (forced true if in SCALAR
+context, also causes binary_only to be true), defaults to false.
+
+=item cache -- optional HASHREF to be used to cache results of
+binary_to_source.
+
+=back
+
+=cut
+
+# the two global variables below are used to tie the source maps; we
+# probably should be retying them in long lived processes.
+sub source_to_binary{
+    my %param = validate_with(params => \@_,
+			      spec   => {source => {type => SCALAR|ARRAYREF,
+						    },
+					 version => {type => SCALAR|ARRAYREF,
+						     optional => 1,
+						    },
+					 dist => {type => SCALAR|ARRAYREF,
+						  optional => 1,
+						 },
+					 binary_only => {default => 0,
+							},
+					 scalar_only => {default => 0,
+							},
+					 cache => {type => HASHREF,
+						   default => {},
+						  },
+					 schema => {type => OBJECT,
+						    optional => 1,
+						   },
+					},
+			     );
+    if (not defined $config{source_binary_map} and
+	not defined $param{schema}
+       ) {
+	return ();
+    }
+
+    if ($param{scalar_only} or not wantarray) {
+	$param{binary_only} = 1;
+	$param{scalar_only} = 1;
+    }
+
+    my @binaries;
+    my @sources = sort grep {defined $_}
+	make_list(exists $param{source}?$param{source}:[]);
+    my @versions = sort grep {defined $_}
+	make_list(exists $param{version}?$param{version}:[]);
+    return () unless @sources;
+
+    # any src:foo is source package foo with unspecified version
+    @sources = map {s/^src://; $_} @sources;
+    if ($param{schema}) {
+	if ($param{binary_only}) {
+	    my $bin_rs = $param{schema}->resultset('BinPkg')->
+		search_rs({'src_pkg.pkg' => [@sources],
+			   @versions?('src_ver.ver'    => [@versions]):(),
+			  },
+			 {join => {'bin_vers'=>
+				  {'src_ver'=> 'src_pkg'}
+				  },
+			  columns => [qw(pkg)],
+			  order_by => [qw(pkg)],
+			  result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+			  distinct => 1,
+			 },
+			 );
+	    if (exists $param{dist}) {
+		$bin_rs = $bin_rs->
+		    search({-or =>
+			   {'suite.codename' => [make_list($param{dist})],
+			    'suite.suite_name' => [make_list($param{dist})],
+			   }},
+			   {join => {'bin_vers' =>
+				    {'bin_associations' =>
+				     'suite'
+				    }},
+			    });
+	    }
+	    push @binaries,
+		map {$_->{pkg}} $bin_rs->all;
+	    if ($param{scalar_only}) {
+		return join(', ',@binaries);
+	    }
+	    return @binaries;
+
+	}
+	my $src_rs = $param{schema}->resultset('BinVer')->
+	    search_rs({'src_pkg.pkg' => [@sources],
+		       @versions?('src_ver.ver' => [@versions]):(),
+		      },
+		     {join => ['bin_pkg',
+			       'arch',
+			      {'src_ver' => ['src_pkg']},
+			      ],
+		      columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
+		      order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
+		      result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+		      distinct => 1,
+		     },
+		     );
+	push @binaries,
+	    map {[$_->{src_pkg}{pkg},
+		  $_->{src_ver}{ver},
+		  $_->{arch}{arch},
+		 ]}
+	    $src_rs->all;
+	if (not @binaries and not @versions) {
+	    $src_rs = $param{schema}->resultset('BinPkg')->
+		search_rs({pkg => [@sources]},
+			 {join => {'bin_vers' =>
+				   ['arch',
+				   {'src_ver'=>'src_pkg'}],
+				   },
+			  distinct => 1,
+			  result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+			  columns => ['src_pkg.pkg','src_ver.ver','arch.arch'],
+			  order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'],
+			 },
+			 );
+	    push @binaries,
+		map {[$_->{src_pkg}{pkg},
+		      $_->{src_ver}{ver},
+		      $_->{arch}{arch},
+		     ]} $src_rs->all;
+	}
+	return @binaries;
+    }
+    my $cache_key = join("\1",
+			 join("\0",@sources),
+			 join("\0",@versions),
+			 join("\0",@param{qw(binary_only scalar_only)}));
+    if (exists $param{cache}{$cache_key}) {
+	return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
+	    @{$param{cache}{$cache_key}};
+    }
+    my @return;
+    my %binaries;
+    if ($param{binary_only}) {
+	for my $source (@sources) {
+	    _tie_sourcetobinary;
+	    # avoid autovivification
+	    my $src = $_sourcetobinary{$source};
+	    if (not defined $src) {
+		next if @versions;
+		_tie_binarytosource;
+		if (exists $_binarytosource{$source}) {
+		    $binaries{$source} = 1;
+		}
+		next;
+	    }
+	    my @src_vers = @versions;
+	    if (not @versions) {
+		@src_vers = keys %{$src};
+	    }
+	    for my $ver (@src_vers) {
+		$binaries{$_->[0]} = 1
+		    foreach @{$src->{$ver}//[]};
+	    }
+	}
+	# return if we have any results.
+	@return = sort keys %binaries;
+	if ($param{scalar_only}) {
+	    @return = join(', ',@return);
+	}
+	goto RETURN_RESULT;
+    }
+    for my $source (@sources) {
+	_tie_sourcetobinary;
+	my $src = $_sourcetobinary{$source};
+	# there isn't a source package, so return this as a binary packages if a
+	# version hasn't been specified
+	if (not defined $src) {
+	    next if @versions;
+	    _tie_binarytosource;
+	    if (exists $_binarytosource{$source}) {
+		my $bin = $_binarytosource{$source};
+		for my $ver (keys %{$bin}) {
+		    for my $arch (keys %{$bin->{$ver}}) {
+			$binaries{$bin}{$ver}{$arch} = 1;
+		    }
+		}
+	    }
+	    next;
+	}
+	for my $bin_ver_archs (values %{$src}) {
+	    for my $bva (@{$bin_ver_archs}) {
+		$binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1;
+	    }
+	}
+    }
+    for my $bin (sort keys %binaries) {
+	for my $ver (sort keys %{$binaries{$bin}}) {
+	    for my $arch (sort keys %{$binaries{$bin}{$ver}}) {
+		push @return,
+		    [$bin,$ver,$arch];
+	    }
+	}
+    }
+RETURN_RESULT:
+    $param{cache}{$cache_key} = \@return;
+    return $param{scalar_only} ? $return[0] : @return;
+}
+
+
+=head2 sourcetobinary
 
 Returns a list of references to triplets of binary package names, versions,
 and architectures corresponding to a given source package name and version.
@@ -173,74 +630,303 @@ returned, without the architecture.
 
 =cut
 
-my %_sourcetobinary;
 sub sourcetobinary {
     my ($srcname, $srcver) = @_;
-
-    if (tied %_sourcetobinary or
-	    tie %_sourcetobinary, 'MLDBM',
-		$gSourceBinaryMap, O_RDONLY) {
-	# avoid autovivification
-	my $source = $_sourcetobinary{$srcname};
-	return () unless defined $source;
-	my %source = %{$source};
-	if (exists $source{$srcver}) {
-	    my $bin = $source{$srcver};
-	    return () unless defined $bin;
-	    return @$bin;
-	}
+    _tie_sourcetobinary;
+    # avoid autovivification
+    my $source = $_sourcetobinary{$srcname};
+    return () unless defined $source;
+    if (exists $source->{$srcver}) {
+	 my $bin = $source->{$srcver};
+	 return () unless defined $bin;
+	 return @$bin;
     }
-
     # No $gSourceBinaryMap, or it didn't have an entry for this name and
     # version. Try $gPackageSource (unversioned) instead.
     my @srcpkgs = getsrcpkgs($srcname);
     return map [$_, $srcver], @srcpkgs;
 }
 
-=item getversions
+=head2 getversions
 
 Returns versions of the package in a distribution at a specific
 architecture
 
 =cut
 
-my %_versions;
 sub getversions {
     my ($pkg, $dist, $arch) = @_;
-    return () unless defined $gVersionIndex;
-    $dist = 'unstable' unless defined $dist;
+    return get_versions(package=>$pkg,
+			dist => $dist,
+			defined $arch ? (arch => $arch):(),
+		       );
+}
 
-    unless (tied %_versions) {
-        tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
-            or die "can't open versions index: $!";
-    }
-    my $version = $_versions{$pkg};
-    return () unless defined $version;
-    my %version = %{$version};
-
-    if (defined $arch and exists $version{$dist}{$arch}) {
-        my $ver = $version{$pkg}{$dist}{$arch};
-        return $ver if defined $ver;
-        return ();
-    } else {
-        my %uniq;
-        for my $ar (keys %{$version{$dist}}) {
-            $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
-        }
-        if (%uniq) {
-            return keys %uniq;
-        } elsif (exists $version{$dist}{source}) {
-            # Maybe this is actually a source package with no corresponding
-            # binaries?
-            return $version{$dist}{source};
-        } else {
-            return ();
-        }
-    }
+
+
+=head2 get_versions
+
+     get_versions(package=>'foopkg',
+                  dist => 'unstable',
+                  arch => 'i386',
+                 );
+
+Returns a list of the versions of package in the distributions and
+architectures listed. This routine only returns unique values.
+
+=over
+
+=item package -- package to return list of versions
+
+=item dist -- distribution (unstable, stable, testing); can be an
+arrayref
+
+=item arch -- architecture (i386, source, ...); can be an arrayref
+
+=item time -- returns a version=>time hash at which the newest package
+matching this version was uploaded
+
+=item source -- returns source/version instead of just versions
+
+=item no_source_arch -- discards the source architecture when arch is
+not passed. [Used for finding the versions of binary packages only.]
+Defaults to 0, which does not discard the source architecture. (This
+may change in the future, so if you care, please code accordingly.)
+
+=item return_archs -- returns a version=>[archs] hash indicating which
+architectures are at which versions.
+
+=item largest_source_version_only -- if there is more than one source
+version in a particular distribution, discards all versions but the
+largest in that distribution. Defaults to 1, as this used to be the
+way that the Debian archive worked.
+
+=back
+
+When called in scalar context, this function will return hashrefs or
+arrayrefs as appropriate, in list context, it will return paired lists
+or unpaired lists as appropriate.
+
+=cut
+
+our %_versions;
+our %_versions_time;
+
+sub get_versions{
+     my %param = validate_with(params => \@_,
+				spec   => {package => {type => SCALAR|ARRAYREF,
+						      },
+					   dist    => {type => SCALAR|ARRAYREF,
+						       default => 'unstable',
+						      },
+					   arch    => {type => SCALAR|ARRAYREF,
+						       optional => 1,
+						      },
+					   time    => {type    => BOOLEAN,
+						       default => 0,
+						      },
+					   source  => {type    => BOOLEAN,
+						       default => 0,
+						      },
+					   no_source_arch => {type => BOOLEAN,
+							      default => 0,
+							     },
+					   return_archs => {type => BOOLEAN,
+							    default => 0,
+							   },
+					   largest_source_version_only => {type => BOOLEAN,
+								       default => 1,
+									  },
+					   schema => {type => OBJECT,
+						      optional => 1,
+						     },
+					  },
+			      );
+     if (defined $param{schema}) {
+	 my @src_packages;
+	 my @bin_packages;
+	 for my $pkg (make_list($param{package})) {
+	     if ($pkg =~ /^src:(.+)/) {
+		 push @src_packages,
+		     $1;
+	     } else {
+		push @bin_packages,$pkg;
+	     }
+	 }
+
+	 my $s = $param{schema};
+	 use Data::Printer;
+	 p @src_packages;
+	 my %return;
+	 if (@src_packages) {
+	     my $src_rs = $s->resultset('SrcVer')->
+		 search({'src_pkg.pkg'=>[@src_packages],
+			 -or => {'suite.codename' => [make_list($param{dist})],
+				 'suite.suite_name' => [make_list($param{dist})],
+				}
+			},
+		       {join => ['src_pkg',
+				{
+				 src_associations=>'suite'},
+				],
+			'+select' => [qw(src_pkg.pkg),
+				      qw(suite.codename),
+				      qw(src_associations.modified),
+				      q(CONCAT(src_pkg.pkg,'/',me.ver))],
+			'+as' => ['src_pkg_name','codename',
+				  'modified_time',
+				  qw(src_pkg_ver)],
+			result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+			order_by => {-desc => 'me.ver'},
+		       },
+		       );
+	     my %completed_dists;
+	     for my $src ($src_rs->all()) {
+		 my $val = 'source';
+		 if ($param{time}) {
+		     $val = DateTime::Format::Pg->
+			 parse_datetime($src->{modified_time})->
+			 epoch();
+		 }
+		 if ($param{largest_source_version_only}) {
+		     next if $completed_dists{$src->{codename}};
+		     $completed_dists{$src->{codename}} = 1;
+		 }
+		 if ($param{source}) {
+		     $return{$src->{src_pkg_ver}} = $val;
+		 } else {
+		     $return{$src->{ver}} = $val;
+		 }
+	     }
+	 }
+	 if (@bin_packages) {
+	     my $bin_rs = $s->resultset('BinVer')->
+		 search({'bin_pkg.pkg' => [@bin_packages],
+			 -or => {'suite.codename' => [make_list($param{dist})],
+				 'suite.suite_name' => [make_list($param{dist})],
+				},
+			},
+		       {join => ['bin_pkg',
+				{
+				 'src_ver'=>'src_pkg'},
+				{
+				 bin_associations => 'suite'},
+				 'arch',
+				],
+			'+select' => [qw(bin_pkg.pkg arch.arch suite.codename),
+				      qw(bin_associations.modified),
+				      qw(src_pkg.pkg),q(CONCAT(src_pkg.pkg,'/',me.ver)),
+				     ],
+			'+as' => ['bin_pkg','arch','codename',
+				  'modified_time',
+				  'src_pkg_name','src_pkg_ver'],
+			result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+			order_by => {-desc => 'src_ver.ver'},
+		       });
+	     if (exists $param{arch}) {
+		 $bin_rs =
+		     $bin_rs->search({'arch.arch' => [make_list($param{arch})]},
+				    {
+				     join => 'arch'}
+				    );
+	     }
+	     my %completed_dists;
+	     for my $bin ($bin_rs->all()) {
+		 my $key = $bin->{ver};
+		 if ($param{source}) {
+		     $key = $bin->{src_pkg_ver};
+		 }
+		 my $val = $bin->{arch};
+		 if ($param{time}) {
+		     $val = DateTime::Format::Pg->
+			 parse_datetime($bin->{modified_time})->
+			 epoch();
+		 }
+		 if ($param{largest_source_version_only}) {
+		     if ($completed_dists{$bin->{codename}} and not
+			 exists $return{$key}) {
+			 next;
+		     }
+		     $completed_dists{$bin->{codename}} = 1;
+		 }
+		 push @{$return{$key}},
+		     $val;
+	     }
+	 }
+	 if ($param{return_archs}) {
+	     if ($param{time} or $param{return_archs}) {
+		 return wantarray?%return :\%return;
+	     }
+	     return wantarray?keys %return :[keys %return];
+	 }
+     }
+     my $versions;
+     if ($param{time}) {
+	  return () if not defined $gVersionTimeIndex;
+	  unless (tied %_versions_time) {
+	       tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY
+		    or die "can't open versions index $gVersionTimeIndex: $!";
+	  }
+	  $versions = \%_versions_time;
+     }
+     else {
+	  return () if not defined $gVersionIndex;
+	  unless (tied %_versions) {
+	       tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
+		    or die "can't open versions index $gVersionIndex: $!";
+	  }
+	  $versions = \%_versions;
+     }
+     my %versions;
+     for my $package (make_list($param{package})) {
+	  my $source_only = 0;
+	  if ($package =~ s/^src://) {
+	       $source_only = 1;
+	  }
+	  my $version = $versions->{$package};
+	  next unless defined $version;
+	  for my $dist (make_list($param{dist})) {
+	       for my $arch (exists $param{arch}?
+			     make_list($param{arch}):
+			     (grep {not $param{no_source_arch} or
+					$_ ne 'source'
+				    } $source_only?'source':keys %{$version->{$dist}})) {
+		    next unless defined $version->{$dist}{$arch};
+		    my @vers = ref $version->{$dist}{$arch} eq 'HASH' ?
+			keys %{$version->{$dist}{$arch}} :
+			    make_list($version->{$dist}{$arch});
+		    if ($param{largest_source_version_only} and
+			$arch eq 'source' and @vers > 1) {
+			# order the versions, then pick the biggest version number
+			@vers = sort_versions(@vers);
+			@vers = $vers[-1];
+		    }
+		    for my $ver (@vers) {
+			 my $f_ver = $ver;
+			 if ($param{source}) {
+			      ($f_ver) = make_source_versions(package => $package,
+							      arch => $arch,
+							      versions => $ver);
+			      next unless defined $f_ver;
+			 }
+			 if ($param{time}) {
+			      $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
+			 }
+			 else {
+			      push @{$versions{$f_ver}},$arch;
+			 }
+		    }
+	       }
+	  }
+     }
+     if ($param{time} or $param{return_archs}) {
+	  return wantarray?%versions :\%versions;
+     }
+     return wantarray?keys %versions :[keys %versions];
 }
 
 
-=item makesourceversions
+=head2 makesourceversions
 
      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 
@@ -251,57 +937,162 @@ version numbers differ from binary version numbers.
 
 =cut
 
-my %_sourceversioncache = ();
+our %_sourceversioncache = ();
 sub makesourceversions {
-    my $pkg = shift;
-    my $arch = shift;
-    my %sourceversions;
+    my ($package,$arch,@versions) = @_;
+    die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
+	 if $package =~ /,/;
+    return make_source_versions(package => $package,
+				(defined $arch)?(arch => $arch):(),
+				versions => \@versions
+			       );
+}
+
+=head2 make_source_versions
+
+     make_source_versions(package => 'foo',
+                          arch    => 'source',
+                          versions => '0.1.1',
+                          guess_source => 1,
+                          warnings => \$warnings,
+                         );
 
-    for my $version (@_) {
-        if ($version =~ m[/]) {
-            # Already a source version.
+An extended version of makesourceversions (which calls this function
+internally) that allows for multiple packages, architectures, and
+outputs warnings and debugging information to provided SCALARREFs or
+HANDLEs.
+
+The guess_source option determines whether the source package is
+guessed at if there is no obviously correct package. Things that use
+this function for non-transient output should set this to false,
+things that use it for transient output can set this to true.
+Currently it defaults to true, but that is not a sane option.
+
+
+=cut
+
+sub make_source_versions {
+    my %param = validate_with(params => \@_,
+			      spec   => {package => {type => SCALAR|ARRAYREF,
+						    },
+					 arch    => {type => SCALAR|ARRAYREF|UNDEF,
+						     default => ''
+						    },
+					 versions => {type => SCALAR|ARRAYREF,
+						      default => [],
+						     },
+					 guess_source => {type => BOOLEAN,
+							  default => 1,
+							 },
+					 source_version_cache => {type => HASHREF,
+								  optional => 1,
+								 },
+					 debug    => {type => SCALARREF|HANDLE,
+						      optional => 1,
+						     },
+					 warnings => {type => SCALARREF|HANDLE,
+						      optional => 1,
+						     },
+					 schema => {type => OBJECT,
+						    optional => 1,
+						   },
+					},
+			     );
+    my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
+
+    my @packages = grep {defined $_ and length $_ } make_list($param{package});
+    my @archs    = grep {defined $_ } make_list ($param{arch});
+    if (not @archs) {
+	push @archs, '';
+    }
+    if (not exists $param{source_version_cache}) {
+	$param{source_version_cache} = \%_sourceversioncache;
+    }
+    if (grep {/,/} make_list($param{package})) {
+	croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
+    }
+    my %sourceversions;
+    for my $version (make_list($param{versions})) {
+        if ($version =~ m{(.+)/([^/]+)$}) {
+	    # Already a source version.
             $sourceversions{$version} = 1;
+	    next unless exists $param{warnings};
+	    # check to see if this source version is even possible
+	    my @bin_versions = sourcetobinary($1,$2);
+	    if (not @bin_versions or
+		@{$bin_versions[0]} != 3) {
+		print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
+	    }
         } else {
-            my $cachearch = (defined $arch) ? $arch : '';
-            my $cachekey = "$pkg/$cachearch/$version";
-            if (exists($_sourceversioncache{$cachekey})) {
-                for my $v (@{$_sourceversioncache{$cachekey}}) {
-		    $sourceversions{$v} = 1;
+	    if (not @packages) {
+		croak "You must provide at least one package if the versions are not fully qualified";
+	    }
+	    for my $pkg (@packages) {
+		if ($pkg =~ /^src:(.+)/) {
+		    $sourceversions{"$1/$version"} = 1;
+		    next unless exists $param{warnings};
+		    # check to see if this source version is even possible
+		    my @bin_versions = sourcetobinary($1,$version);
+		    if (not @bin_versions or
+			@{$bin_versions[0]} != 3) {
+			print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n";
+		    }
+		    next;
+		}
+		for my $arch (@archs) {
+		    my $cachearch = (defined $arch) ? $arch : '';
+		    my $cachekey = "$pkg/$cachearch/$version";
+		    if (exists($param{source_version_cache}{$cachekey})) {
+			for my $v (@{$param{source_version_cache}{$cachekey}}) {
+			    $sourceversions{$v} = 1;
+			}
+			next;
+		    }
+		    elsif ($param{guess_source} and
+			   exists$param{source_version_cache}{$cachekey.'/guess'}) {
+			for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
+			    $sourceversions{$v} = 1;
+			}
+			next;
+		    }
+		    my @srcinfo = binary_to_source(binary => $pkg,
+						   version => $version,
+						   length($arch)?(arch    => $arch):());
+		    if (not @srcinfo) {
+			# We don't have explicit information about the
+			# binary-to-source mapping for this version
+			# (yet).
+			print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
+			if ($param{guess_source}) {
+			    # Lets guess it
+			    my $pkgsrc = getpkgsrc();
+			    if (exists $pkgsrc->{$pkg}) {
+				@srcinfo = ([$pkgsrc->{$pkg}, $version]);
+			    } elsif (getsrcpkgs($pkg)) {
+				# If we're looking at a source package
+				# that doesn't have a binary of the
+				# same name, just try the same
+				# version.
+				@srcinfo = ([$pkg, $version]);
+			    } else {
+				next;
+			    }
+			    # store guesses in a slightly different location
+			    $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+			}
+		    }
+		    else {
+			# only store this if we didn't have to guess it
+			$param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+		    }
+		    $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 		}
-                next;
-            }
-
-            my @srcinfo = binarytosource($pkg, $version, $arch);
-            unless (@srcinfo) {
-                # We don't have explicit information about the
-                # binary-to-source mapping for this version (yet). Since
-                # this is a CGI script and our output is transient, we can
-                # get away with just looking in the unversioned map; if it's
-                # wrong (as it will be when binary and source package
-                # versions differ), too bad.
-                my $pkgsrc = getpkgsrc();
-                if (exists $pkgsrc->{$pkg}) {
-                    @srcinfo = ([$pkgsrc->{$pkg}, $version]);
-                } elsif (getsrcpkgs($pkg)) {
-                    # If we're looking at a source package that doesn't have
-                    # a binary of the same name, just try the same version.
-                    @srcinfo = ([$pkg, $version]);
-                } else {
-                    next;
-                }
-            }
-            $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
-            $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+	    }
         }
     }
-
     return sort keys %sourceversions;
 }
 
 
 
-=back
-
-=cut
-
 1;