Debbugs/Packages.pm

   1 package Debbugs::Packages;
   2
   3 use strict;
   4
   5 use Debbugs::Config qw(:config :globals);
   6
   7 use Exporter ();
   8 use vars qw($VERSION @ISA @EXPORT);
   9
  10 BEGIN {
  11     $VERSION = 1.00;
  12
  13     @ISA = qw(Exporter);
  14     @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs
  15                  binarytosource sourcetobinary getversions);
  16 }
  17
  18 use Fcntl qw(O_RDONLY);
  19 use MLDBM qw(DB_File);
  20
  21 $MLDBM::RemoveTaint = 1;
  22
  23 =head1 NAME
  24
  25 Debbugs::Packages - debbugs binary/source package handling
  26
  27 =head1 DESCRIPTION
  28
  29 The Debbugs::Packages module provides support functions to map binary
  30 packages to their corresponding source packages and vice versa. (This makes
  31 sense for software distributions, where developers may work on a single
  32 source package which produces several binary packages for use by users; it
  33 may not make sense in other contexts.)
  34
  35 =head1 METHODS
  36
  37 =over 8
  38
  39 =item getpkgsrc
  40
  41 Returns a reference to a hash of binary package names to their corresponding
  42 source package names.
  43
  44 =cut
  45
  46 my $_pkgsrc;
  47 my $_pkgcomponent;
  48 sub getpkgsrc {
  49     return $_pkgsrc if $_pkgsrc;
  50     return {} unless defined $Debbugs::Packages::gPackageSource;
  51     my %pkgsrc;
  52     my %pkgcomponent;
  53
  54     open(MM,"$Debbugs::Packages::gPackageSource")
  55         or die("open $Debbugs::Packages::gPackageSource: $!");
  56     while(<MM>) {
  57         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
  58         my ($bin,$cmp,$src)=($1,$2,$3);
  59         $bin =~ y/A-Z/a-z/;
  60         $pkgsrc{$bin}= $src;
  61         $pkgcomponent{$bin}= $cmp;
  62     }
  63     close(MM);
  64     $_pkgsrc = \%pkgsrc;
  65     $_pkgcomponent = \%pkgcomponent;
  66     return $_pkgsrc;
  67 }
  68
  69 =item getpkgcomponent
  70
  71 Returns a reference to a hash of binary package names to the component of
  72 the archive containing those binary packages (e.g. "main", "contrib",
  73 "non-free").
  74
  75 =cut
  76
  77 sub getpkgcomponent {
  78     return $_pkgcomponent if $_pkgcomponent;
  79     getpkgsrc();
  80     return $_pkgcomponent;
  81 }
  82
  83 =item getsrcpkgs
  84
  85 Returns a list of the binary packages produced by a given source package.
  86
  87 =cut
  88
  89 sub getsrcpkgs {
  90     my $src = shift;
  91     return () if !$src;
  92     my %pkgsrc = %{getpkgsrc()};
  93     my @pkgs;
  94     foreach ( keys %pkgsrc ) {
  95         push @pkgs, $_ if $pkgsrc{$_} eq $src;
  96     }
  97     return @pkgs;
  98 }
  99
 100 =item binarytosource
 101
 102 Returns a reference to the source package name and version pair
 103 corresponding to a given binary package name, version, and architecture. If
 104 undef is passed as the architecture, returns a list of references to all
 105 possible pairs of source package names and versions for all architectures,
 106 with any duplicates removed.
 107
 108 =cut
 109
 110 my %_binarytosource;
 111 sub binarytosource {
 112     my ($binname, $binver, $binarch) = @_;
 113
 114     # TODO: This gets hit a lot, especially from buggyversion() - probably
 115     # need an extra cache for speed here.
 116
 117     if (tied %_binarytosource or
 118             tie %_binarytosource, 'MLDBM',
 119                 $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
 120         # avoid autovivification
 121         if (exists $_binarytosource{$binname} and
 122                 exists $_binarytosource{$binname}{$binver}) {
 123             if (defined $binarch) {
 124                 my $src = $_binarytosource{$binname}{$binver}{$binarch};
 125                 return () unless defined $src; # not on this arch
 126                 # Copy the data to avoid tiedness problems.
 127                 return [@$src];
 128             } else {
 129                 # Get (srcname, srcver) pairs for all architectures and
 130                 # remove any duplicates. This involves some slightly tricky
 131                 # multidimensional hashing; sorry. Fortunately there'll
 132                 # usually only be one pair returned.
 133                 my %uniq;
 134                 for my $ar (keys %{$_binarytosource{$binname}{$binver}}) {
 135                     my $src = $_binarytosource{$binname}{$binver}{$ar};
 136                     next unless defined $src;
 137                     $uniq{$src->[0]}{$src->[1]} = 1;
 138                 }
 139                 my @uniq;
 140                 for my $sn (sort keys %uniq) {
 141                     push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 142                 }
 143                 return @uniq;
 144             }
 145         }
 146     }
 147
 148     # No $gBinarySourceMap, or it didn't have an entry for this name and
 149     # version.
 150     return ();
 151 }
 152
 153 =item sourcetobinary
 154
 155 Returns a list of references to triplets of binary package names, versions,
 156 and architectures corresponding to a given source package name and version.
 157 If the given source package name and version cannot be found in the database
 158 but the source package name is in the unversioned package-to-source map
 159 file, then a reference to a binary package name and version pair will be
 160 returned, without the architecture.
 161
 162 =cut
 163
 164 my %_sourcetobinary;
 165 sub sourcetobinary {
 166     my ($srcname, $srcver) = @_;
 167
 168     if (tied %_sourcetobinary or
 169             tie %_sourcetobinary, 'MLDBM',
 170                 $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
 171         # avoid autovivification
 172         if (exists $_sourcetobinary{$srcname} and
 173                 exists $_sourcetobinary{$srcname}{$srcver}) {
 174             my $bin = $_sourcetobinary{$srcname}{$srcver};
 175             return () unless defined $bin;
 176             # Copy the data to avoid tiedness problems.
 177             return @$bin;
 178         }
 179     }
 180
 181     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 182     # version. Try $gPackageSource (unversioned) instead.
 183     my @srcpkgs = getsrcpkgs($srcname);
 184     return map [$_, $srcver], @srcpkgs;
 185 }
 186
 187 =item getversions
 188
 189 Returns versions of the package in distribution at a specific architecture
 190
 191 =cut
 192
 193 my %_versions;
 194 sub getversions {
 195     my ($pkg, $dist, $arch) = @_;
 196     return () unless defined $debbugs::gVersionIndex;
 197     $dist = 'unstable' unless defined $dist;
 198
 199     unless (tied %_versions) {
 200         tie %_versions, 'MLDBM', $debbugs::gVersionIndex, O_RDONLY
 201             or die "can't open versions index: $!";
 202     }
 203
 204     if (defined $arch and exists $_versions{$pkg}{$dist}{$arch}) {
 205         my $ver = $_versions{$pkg}{$dist}{$arch};
 206         return $ver if defined $ver;
 207         return ();
 208     } else {
 209         my %uniq;
 210         for my $ar (keys %{$_versions{$pkg}{$dist}}) {
 211             $uniq{$_versions{$pkg}{$dist}{$ar}} = 1 unless $ar eq 'source';
 212         }
 213         if (%uniq) {
 214             return keys %uniq;
 215         } elsif (exists $_versions{$pkg}{$dist}{source}) {
 216             # Maybe this is actually a source package with no corresponding
 217             # binaries?
 218             return $_versions{$pkg}{$dist}{source};
 219         } else {
 220             return ();
 221         }
 222     }
 223 }
 224
 225
 226
 227 =back
 228
 229 =cut
 230
 231 1;