Debbugs/Packages.pm

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