X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FPackages.pm;h=7103fc10daf9fefd1afaa7e2918f57267ae7300d;hb=acf5b623e6379e7e8053cf9e795d8b4931f26c3b;hp=750bff252ebdf2dc521b905bed971e176881ba99;hpb=dcb283c0a89bb0c05b78584657f6c8d12f6bf873;p=debbugs.git

diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm
index 750bff2..7103fc1 100644
--- a/Debbugs/Packages.pm
+++ b/Debbugs/Packages.pm
@@ -37,6 +37,8 @@ use Storable qw(dclone);
 use Params::Validate qw(validate_with :types);
 use Debbugs::Common qw(make_list);
 
+use List::Util qw(min max);
+
 $MLDBM::DumpMeth = 'portable';
 $MLDBM::RemoveTaint = 1;
 
@@ -135,37 +137,38 @@ sub binarytosource {
     # need an extra cache for speed here.
     return () unless defined $gBinarySourceMap;
 
-    if (tied %_binarytosource or
-	    tie %_binarytosource, 'MLDBM',
-		$gBinarySourceMap, O_RDONLY) {
-	# 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;
-	    }
-	}
+    if (not tied %_binarytosource) {
+	 tie %_binarytosource, MLDBM => $gBinarySourceMap, O_RDONLY or
+	      die "Unable to open $gBinarySourceMap for reading";
+    }
+
+    # 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;
+	 }
     }
 
     # No $gBinarySourceMap, or it didn't have an entry for this name and
@@ -188,20 +191,22 @@ our %_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;
-	}
+    if (not tied %_sourcetobinary) {
+	 tie %_sourcetobinary, MLDBM => $gSourceBinaryMap, O_RDONLY or
+	      die "Unable top open $gSourceBinaryMap for reading";
     }
 
+
+
+    # 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;
+    }
     # No $gSourceBinaryMap, or it didn't have an entry for this name and
     # version. Try $gPackageSource (unversioned) instead.
     my @srcpkgs = getsrcpkgs($srcname);
@@ -249,6 +254,11 @@ 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.)
+
 =back
 
 =cut
@@ -258,7 +268,7 @@ our %_versions_time;
 
 sub get_versions{
      my %param = validate_with(params => \@_,
-				spec   => {package => {type => SCALAR,
+				spec   => {package => {type => SCALAR|ARRAYREF,
 						      },
 					   dist    => {type => SCALAR|ARRAYREF,
 						       default => 'unstable',
@@ -272,6 +282,9 @@ sub get_versions{
 					   source  => {type    => BOOLEAN,
 						       default => 0,
 						      },
+					   no_source_arch => {type => BOOLEAN,
+							      default => 0,
+							     },
 					  },
 			       );
      my $versions;
@@ -298,7 +311,9 @@ sub get_versions{
 	  for my $dist (make_list($param{dist})) {
 	       for my $arch (exists $param{arch}?
 			     make_list($param{arch}):
-			     (keys %{$version->{$dist}})) {
+			     (grep {not $param{no_source_arch} or
+					 $_ ne 'source'
+			       } keys %{$version->{$dist}})) {
 		    next unless defined $version->{$dist}{$arch};
 		    for my $ver (ref $version->{$dist}{$arch} ?
 				 keys %{$version->{$dist}{$arch}} :
@@ -306,7 +321,8 @@ sub get_versions{
 				) {
 			 my $f_ver = $ver;
 			 if ($param{source}) {
-			      $f_ver = makesourceversions($package,$arch,$ver)
+			      ($f_ver) = makesourceversions($package,$arch,$ver);
+			      next unless defined $f_ver;
 			 }
 			 if ($param{time}) {
 			      $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver});
@@ -341,6 +357,8 @@ 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 =~ /,/;
 
     for my $version (@_) {
         if ($version =~ m[/]) {