* fix extraneous semicolon

[debbugs.git] / Debbugs / Packages.pm

diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm
index 8ef34515b3776f808222b0cc5704c42e1a12c457..f43e8b54e20cf9b00ad3948527ad7f7dbabeb74d 100644 (file)
--- a/Debbugs/Packages.pm
+++ b/Debbugs/Packages.pm
@@ -139,6 +139,9 @@ 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
@@ -162,7 +165,10 @@ binary_to_source.
 
 =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 %_sourcetobinary;
 sub binary_to_source{
     my %param = validate_with(params => \@_,
                              spec   => {binary => {type => SCALAR|ARRAYREF,
@@ -193,12 +199,12 @@ sub binary_to_source{
     }
 
     my @source;
-    my @packages = grep {defined $_} make_list(exists $param{package}?$param{package}:[]);
+    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 @packages;
+    return () unless @binaries;
     my $cache_key = join("\1",
-                        join("\0",@packages),
+                        join("\0",@binaries),
                         join("\0",@versions),
                         join("\0",@archs),
                         join("\0",@param{qw(source_only scalar_only)}));
@@ -206,8 +212,8 @@ sub binary_to_source{
        return $param{scalar_only} ? $param{cache}{$cache_key}[0]:
            @{$param{cache}{$cache_key}};
     }
-    for my $package (make_list($param{package})) {
-       if ($package =~ m/^src:(.+)$/) {
+    for my $binary (@binaries) {
+       if ($binary =~ m/^src:(.+)$/) {
            push @source,[$1,''];
            next;
        }
@@ -216,12 +222,12 @@ sub binary_to_source{
                die "Unable to open $config{binary_source_map} for reading";
        }
        # avoid autovivification
-       my $binary = $_binarytosource{$package};
+       my $bin = $_binarytosource{$binary};
        if (not @versions) {
-           next unless defined $binary;
-           for my $ver (keys %{$binary}) {
-               for my $ar (keys %{$binary->{$ver}}) {
-                   my $src = $binary->{$ver}{$ar};
+           next unless defined $bin;
+           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]];
                }
@@ -230,9 +236,9 @@ sub binary_to_source{
        else {
            my $found_one_version = 0;
            for my $version (@versions) {
-               next unless exists $binary->{$version};
-               if (exists $binary->{$version}{all}) {
-                   push @source,dclone($binary->{$version}{all});
+               next unless exists $bin->{$version};
+               if (exists $bin->{$version}{all}) {
+                   push @source,dclone($bin->{$version}{all});
                    next;
                }
                my @t_archs;
@@ -240,15 +246,38 @@ sub binary_to_source{
                    @t_archs = @archs;
                }
                else {
-                   @t_archs = keys %{$binary->{$version}};
+                   @t_archs = keys %{$bin->{$version}};
                }
                for my $arch (@t_archs) {
-                   push @source,dclone($binary->{$version}{$arch}) if
-                       exists $binary->{$version}{$arch};
+                   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.
+
+       if (not tied %_sourcetobinary) {
+           tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or
+               die "Unable top open $gSourceBinaryMap for reading";
+       }
+       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}) {
@@ -288,13 +317,12 @@ returned, without the architecture.
 
 =cut
 
-our %_sourcetobinary;
 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, MLDBM => $config{source_binary_map}, O_RDONLY or
+           die "Unable top open $config{source_binary_map} for reading";
     }
 
 
@@ -416,6 +444,10 @@ sub get_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})) {
@@ -423,7 +455,7 @@ sub get_versions{
                             make_list($param{arch}):
                             (grep {not $param{no_source_arch} or
                                        $_ ne 'source'
-                                   } keys %{$version->{$dist}})) {
+                                   } $source_only?'source':keys %{$version->{$dist}})) {
                    next unless defined $version->{$dist}{$arch};
                    for my $ver (ref $version->{$dist}{$arch} ?
                                 keys %{$version->{$dist}{$arch}} :
@@ -583,7 +615,7 @@ sub make_source_versions {
                    }
                    my @srcinfo = binary_to_source(binary => $pkg,
                                                   version => $version,
-                                                  arch    => $arch);
+                                                  length($arch)?(arch    => $arch):());
                    if (not @srcinfo) {
                        # We don't have explicit information about the
                        # binary-to-source mapping for this version