properly support src: packages in make_source_versions

[debbugs.git] / Debbugs / Packages.pm

diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm
index b448db3c42e2731009575251f5a15086768711af..47c37f9f7bbd6bb0dba0bd4d9e5e72f497452962 100644 (file)
--- a/Debbugs/Packages.pm
+++ b/Debbugs/Packages.pm
@@ -60,9 +60,7 @@ 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.
@@ -96,7 +94,7 @@ sub getpkgsrc {
     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",
@@ -110,7 +108,7 @@ sub getpkgcomponent {
     return $_pkgcomponent;
 }
 
-=item getsrcpkgs
+=head2 getsrcpkgs
 
 Returns a list of the binary packages produced by a given source package.
 
@@ -123,7 +121,7 @@ sub getsrcpkgs {
     return @{$_srcpkg->{$src}};
 }
 
-=item binarytosource
+=head2 binarytosource
 
 Returns a reference to the source package name and version pair
 corresponding to a given binary package name, version, and architecture.
@@ -146,6 +144,9 @@ sub binarytosource {
     # need an extra cache for speed here.
     return () unless defined $gBinarySourceMap;
 
+    if ($binname =~ m/^src:(.+)$/) {
+       return $1;
+    }
     if (not tied %_binarytosource) {
         tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
              die "Unable to open $gBinarySourceMap for reading";
@@ -169,6 +170,9 @@ sub binarytosource {
     elsif (exists $binary{$binver}) {
         if (defined $binarch) {
              my $src = $binary{$binver}{$binarch};
+             if (not defined $src and exists $binary{$binver}{all}) {
+                 $src = $binary{$binver}{all};
+             }
              return () unless defined $src; # not on this arch
              # Copy the data to avoid tiedness problems.
              return dclone($src);
@@ -196,7 +200,7 @@ sub binarytosource {
     return ();
 }
 
-=item sourcetobinary
+=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.
@@ -221,9 +225,8 @@ sub sourcetobinary {
     # 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;
     }
@@ -233,7 +236,7 @@ sub sourcetobinary {
     return map [$_, $srcver], @srcpkgs;
 }
 
-=item getversions
+=head2 getversions
 
 Returns versions of the package in a distribution at a specific
 architecture
@@ -342,8 +345,8 @@ sub get_versions{
               for my $arch (exists $param{arch}?
                             make_list($param{arch}):
                             (grep {not $param{no_source_arch} or
-                                        $_ ne 'source'
-                              } keys %{$version->{$dist}})) {
+                                       $_ ne 'source'
+                                   } keys %{$version->{$dist}})) {
                    next unless defined $version->{$dist}{$arch};
                    for my $ver (ref $version->{$dist}{$arch} ?
                                 keys %{$version->{$dist}{$arch}} :
@@ -373,7 +376,7 @@ sub get_versions{
 }
 
 
-=item makesourceversions
+=head2 makesourceversions
 
      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 
@@ -423,7 +426,7 @@ sub make_source_versions {
     my %param = validate_with(params => \@_,
                              spec   => {package => {type => SCALAR|ARRAYREF,
                                                    },
-                                        arch    => {type => SCALAR|ARRAYREF,
+                                        arch    => {type => SCALAR|ARRAYREF|UNDEF,
                                                     default => ''
                                                    },
                                         versions => {type => SCALAR|ARRAYREF,
@@ -446,9 +449,8 @@ sub make_source_versions {
     my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
     my ($debug)    = globify_scalar(exists $param{debug}   ?$param{debug}   :undef);
 
-
     my @packages = grep {defined $_ and length $_ } make_list($param{package});
-    my @archs    = grep {defined $_ } make_list ($param{archs});
+    my @archs    = grep {defined $_ } make_list ($param{arch});
     if (not @archs) {
        push @archs, '';
     }
@@ -461,19 +463,31 @@ sub make_source_versions {
     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";
            }
-            # Already a source version.
-            $sourceversions{$version} = 1;
         } else {
            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 $2 do not appear to match any binary packages\n";
+                   }
+                   next;
+               }
                for my $arch (@archs) {
                    my $cachearch = (defined $arch) ? $arch : '';
                    my $cachekey = "$pkg/$cachearch/$version";
@@ -483,6 +497,13 @@ sub make_source_versions {
                        }
                        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 = binarytosource($pkg, $version, $arch);
                    if (not @srcinfo) {
                        # We don't have explicit information about the
@@ -503,10 +524,15 @@ sub make_source_versions {
                            } 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;
-                   $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
                }
            }
         }
@@ -516,8 +542,4 @@ sub make_source_versions {
 
 
 
-=back
-
-=cut
-
 1;