]> git.donarmstrong.com Git - debbugs.git/blobdiff - Debbugs/Packages.pm
Debbugs::packages::get_versions can now use the database
[debbugs.git] / Debbugs / Packages.pm
index 7103fc10daf9fefd1afaa7e2918f57267ae7300d..2cdef213fce3b89abec6349e5e909d1166fb97a7 100644 (file)
@@ -12,18 +12,21 @@ package Debbugs::Packages;
 use warnings;
 use strict;
 
 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 vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
 
+use Carp;
+
+use Debbugs::Config qw(:config :globals);
+
 BEGIN {
     $VERSION = 1.00;
 
      @EXPORT = ();
 BEGIN {
     $VERSION = 1.00;
 
      @EXPORT = ();
-     %EXPORT_TAGS = (versions => [qw(getversions get_versions)],
+     %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
                     mapping  => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
                     mapping  => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
-                                 qw(binarytosource sourcetobinary makesourceversions)
+                                 qw(binary_to_source sourcetobinary makesourceversions),
+                                 qw(source_to_binary),
                                 ],
                    );
      @EXPORT_OK = ();
                                 ],
                    );
      @EXPORT_OK = ();
@@ -35,9 +38,11 @@ use Fcntl qw(O_RDONLY);
 use MLDBM qw(DB_File Storable);
 use Storable qw(dclone);
 use Params::Validate qw(validate_with :types);
 use MLDBM qw(DB_File Storable);
 use Storable qw(dclone);
 use Params::Validate qw(validate_with :types);
-use Debbugs::Common qw(make_list);
+use Debbugs::Common qw(make_list globify_scalar sort_versions);
+use DateTime::Format::Pg;
+use List::AllUtils qw(min max uniq);
 
 
-use List::Util qw(min max);
+use IO::File;
 
 $MLDBM::DumpMeth = 'portable';
 $MLDBM::RemoveTaint = 1;
 
 $MLDBM::DumpMeth = 'portable';
 $MLDBM::RemoveTaint = 1;
@@ -56,9 +61,7 @@ may not make sense in other contexts.)
 
 =head1 METHODS
 
 
 =head1 METHODS
 
-=over 8
-
-=item getpkgsrc
+=head2 getpkgsrc
 
 Returns a reference to a hash of binary package names to their corresponding
 source package names.
 
 Returns a reference to a hash of binary package names to their corresponding
 source package names.
@@ -70,29 +73,30 @@ our $_pkgcomponent;
 our $_srcpkg;
 sub getpkgsrc {
     return $_pkgsrc if $_pkgsrc;
 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;
 
     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);
        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;
     }
        $pkgsrc{$bin}= $src;
        push @{$srcpkg{$src}}, $bin;
        $pkgcomponent{$bin}= $cmp;
     }
-    close(MM);
+    close($fh);
     $_pkgsrc = \%pkgsrc;
     $_pkgcomponent = \%pkgcomponent;
     $_srcpkg = \%srcpkg;
     return $_pkgsrc;
 }
 
     $_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",
 
 Returns a reference to a hash of binary package names to the component of
 the archive containing those binary packages (e.g. "main", "contrib",
@@ -106,7 +110,7 @@ sub getpkgcomponent {
     return $_pkgcomponent;
 }
 
     return $_pkgcomponent;
 }
 
-=item getsrcpkgs
+=head2 getsrcpkgs
 
 Returns a list of the binary packages produced by a given source package.
 
 
 Returns a list of the binary packages produced by a given source package.
 
@@ -119,64 +123,503 @@ sub getsrcpkgs {
     return @{$_srcpkg->{$src}};
 }
 
     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.
 
 
-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 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.
+
+=item cache -- optional HASHREF to be used to cache results of
+binary_to_source.
+
+=back
 
 =cut
 
 
 =cut
 
+# the two global variables below are used to tie the source maps; we
+# probably should be retying them in long lived processes.
 our %_binarytosource;
 our %_binarytosource;
-sub binarytosource {
-    my ($binname, $binver, $binarch) = @_;
+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.
 
     # 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 (not tied %_binarytosource) {
-        tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
-             die "Unable to open $gBinarySourceMap for reading";
+    if ($param{scalar_only} or not wantarray) {
+       $param{source_only} = 1;
+       $param{scalar_only} = 1;
     }
 
     }
 
-    # 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};
-                  next unless defined $src;
-                  $uniq{$src->[0]}{$src->[1]} = 1;
-             }
-             my @uniq;
-             for my $sn (sort keys %uniq) {
-                  push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
-             }
-             return @uniq;
-        }
+    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 $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;
+                   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}};
+               }
+               for my $arch (@t_archs) {
+                   push @source,dclone($bin->{$version}{$arch}) if
+                       exists $bin->{$version}{$arch};
+               }
+           }
+       }
+    }
+
+    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.
     }
 
     # 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.
 
 Returns a list of references to triplets of binary package names, versions,
 and architectures corresponding to a given source package name and version.
@@ -187,23 +630,14 @@ returned, without the architecture.
 
 =cut
 
 
 =cut
 
-our %_sourcetobinary;
 sub sourcetobinary {
     my ($srcname, $srcver) = @_;
 sub sourcetobinary {
     my ($srcname, $srcver) = @_;
-
-    if (not tied %_sourcetobinary) {
-        tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
-             die "Unable top open $gSourceBinaryMap for reading";
-    }
-
-
-
+    _tie_sourcetobinary;
     # avoid autovivification
     my $source = $_sourcetobinary{$srcname};
     return () unless defined $source;
     # avoid autovivification
     my $source = $_sourcetobinary{$srcname};
     return () unless defined $source;
-    my %source = %{$source};
-    if (exists $source{$srcver}) {
-        my $bin = $source{$srcver};
+    if (exists $source->{$srcver}) {
+        my $bin = $source->{$srcver};
         return () unless defined $bin;
         return @$bin;
     }
         return () unless defined $bin;
         return @$bin;
     }
@@ -213,7 +647,7 @@ sub sourcetobinary {
     return map [$_, $srcver], @srcpkgs;
 }
 
     return map [$_, $srcver], @srcpkgs;
 }
 
-=item getversions
+=head2 getversions
 
 Returns versions of the package in a distribution at a specific
 architecture
 
 Returns versions of the package in a distribution at a specific
 architecture
@@ -232,10 +666,10 @@ sub getversions {
 
 =head2 get_versions
 
 
 =head2 get_versions
 
-     get_version(package=>'foopkg',
-                 dist => 'unstable',
-                 arch => 'i386',
-                );
+     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.
 
 Returns a list of the versions of package in the distributions and
 architectures listed. This routine only returns unique values.
@@ -259,8 +693,20 @@ 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.)
 
 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
 
 =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;
 =cut
 
 our %_versions;
@@ -285,8 +731,135 @@ sub get_versions{
                                           no_source_arch => {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;
      my $versions;
      if ($param{time}) {
          return () if not defined $gVersionTimeIndex;
@@ -306,42 +879,54 @@ sub get_versions{
      }
      my %versions;
      for my $package (make_list($param{package})) {
      }
      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
          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'
-                              keys %{$version->{$dist}})) {
+                                       $_ ne 'source'
+                                   } $source_only?'source':keys %{$version->{$dist}})) {
                    next unless defined $version->{$dist}{$arch};
                    next unless defined $version->{$dist}{$arch};
-                   for my $ver (ref $version->{$dist}{$arch} ?
-                                keys %{$version->{$dist}{$arch}} :
-                                $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}) {
                         my $f_ver = $ver;
                         if ($param{source}) {
-                             ($f_ver) = makesourceversions($package,$arch,$ver);
+                             ($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 {
                              next unless defined $f_ver;
                         }
                         if ($param{time}) {
                              $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
                         }
                         else {
-                             $versions{$f_ver} = 1;
+                             push @{$versions{$f_ver}},$arch;
                         }
                    }
               }
          }
      }
                         }
                    }
               }
          }
      }
-     if ($param{time}) {
-         return %versions
+     if ($param{time} or $param{return_archs}) {
+         return wantarray?%versions :\%versions;
      }
      }
-     return keys %versions;
+     return wantarray?keys %versions :[keys %versions];
 }
 
 
 }
 
 
-=item makesourceversions
+=head2 makesourceversions
 
      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 
 
      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 
@@ -354,57 +939,160 @@ version numbers differ from binary version numbers.
 
 our %_sourceversioncache = ();
 sub makesourceversions {
 
 our %_sourceversioncache = ();
 sub makesourceversions {
-    my $pkg = shift;
-    my $arch = shift;
-    my %sourceversions;
-    die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
-        if $pkg =~ /,/;
+    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,
+                         );
+
+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
 
 
-    for my $version (@_) {
-        if ($version =~ m[/]) {
-            # Already a source version.
+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;
             $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 {
         } 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;
                }
                }
-                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 ];
+               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;
+               }
+           }
         }
     }
         }
     }
-
     return sort keys %sourceversions;
 }
 
 
 
     return sort keys %sourceversions;
 }
 
 
 
-=back
-
-=cut
-
 1;
 1;