merge changes from dla source

[debbugs.git] / Debbugs / Packages.pm

diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm
index 222bd41a60b716b8c3e4d0bbcc5608453ee355ae..191b4531f955a02c95964cedb195adad09c794bc 100644 (file)
--- a/Debbugs/Packages.pm
+++ b/Debbugs/Packages.pm
@@ -12,11 +12,11 @@ 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 Debbugs::Config qw(:config :globals);
+
 BEGIN {
     $VERSION = 1.00;
 
@@ -39,6 +39,8 @@ use Debbugs::Common qw(make_list);
 
 use List::Util qw(min max);
 
+use IO::File;
+
 $MLDBM::DumpMeth = 'portable';
 $MLDBM::RemoveTaint = 1;
 
@@ -75,17 +77,17 @@ 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;
@@ -122,10 +124,15 @@ sub getsrcpkgs {
 =item 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
 
@@ -146,7 +153,18 @@ sub binarytosource {
     my $binary = $_binarytosource{$binname};
     return () unless defined $binary;
     my %binary = %{$binary};
-    if (exists $binary{$binver}) {
+    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
@@ -232,10 +250,10 @@ sub getversions {
 
 =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.
@@ -254,8 +272,20 @@ 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;
@@ -263,7 +293,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',
@@ -277,6 +307,12 @@ sub get_versions{
                                           source  => {type    => BOOLEAN,
                                                       default => 0,
                                                      },
+                                          no_source_arch => {type => BOOLEAN,
+                                                             default => 0,
+                                                            },
+                                          return_archs => {type => BOOLEAN,
+                                                           default => 0,
+                                                          },
                                          },
                               );
      my $versions;
@@ -303,7 +339,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}} :
@@ -318,16 +356,16 @@ sub get_versions{
                              $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];
 }