X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FPackages.pm;h=307e1f98005042c17b5ee4a793cfa3b369e617b5;hb=ce23d0291a7bc8a1cb781cb10ae075263e3fd442;hp=5284e2c58f2aeecd459f32f75d96fd4a11f4efd2;hpb=c6d8b358aee776d0b4d7ced29f086d7e32c2b21a;p=debbugs.git

diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm
index 5284e2c..307e1f9 100644
--- a/Debbugs/Packages.pm
+++ b/Debbugs/Packages.pm
@@ -1,18 +1,29 @@
+# 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 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)
 				 ],
@@ -25,6 +36,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);
+
+use List::Util qw(min max);
+
+use IO::File;
 
 $MLDBM::DumpMeth = 'portable';
 $MLDBM::RemoveTaint = 1;
@@ -43,18 +60,16 @@ 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;
@@ -62,24 +77,24 @@ sub getpkgsrc {
     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 die("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 +108,7 @@ sub getpkgcomponent {
     return $_pkgcomponent;
 }
 
-=item getsrcpkgs
+=head2 getsrcpkgs
 
 Returns a list of the binary packages produced by a given source package.
 
@@ -106,17 +121,22 @@ 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. 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.
+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.
+
+If the binary version is not passed either, returns a list of possible
+source package names for all architectures at all versions, with any
+duplicates removed.
 
 =cut
 
-my %_binarytosource;
+our %_binarytosource;
 sub binarytosource {
     my ($binname, $binver, $binarch) = @_;
 
@@ -124,37 +144,49 @@ 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 (not defined $binver) {
+	 my %uniq;
+	 for my $ver (keys %binary) {
+	      for my $ar (keys %{$binary{$ver}}) {
+		   my $src = $binary{$ver}{$ar};
+		   next unless defined $src;
+		   $uniq{$src->[0]} = 1;
+	      }
+	 }
+	 return keys %uniq;
+    }
+    elsif (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
@@ -162,7 +194,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.
@@ -173,74 +205,173 @@ returned, without the architecture.
 
 =cut
 
-my %_sourcetobinary;
+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);
     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.
+
+=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,
+							   },
+					  },
+			       );
+     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 $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}})) {
+		    next unless defined $version->{$dist}{$arch};
+		    for my $ver (ref $version->{$dist}{$arch} ?
+				 keys %{$version->{$dist}{$arch}} :
+				 $version->{$dist}{$arch}
+				) {
+			 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 +382,148 @@ 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,
+                          debug    => \$debug,
+                          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.
 
-    for my $version (@_) {
-        if ($version =~ m[/]) {
+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,
+						     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,
+						     },
+					},
+			     );
+    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});
+    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{(.+)/([^/]+)$}) {
+	    # 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 {
-            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) {
+		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}}) {
+			    $sourceversions{$v} = 1;
+			}
+			next;
+		    }
+		    my @srcinfo = binarytosource($pkg, $version, $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;