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 makesourceversions)
  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 use Storable qw(dclone);
  28
  29 $MLDBM::DumpMeth = 'portable';
  30 $MLDBM::RemoveTaint = 1;
  31
  32 =head1 NAME
  33
  34 Debbugs::Packages - debbugs binary/source package handling
  35
  36 =head1 DESCRIPTION
  37
  38 The Debbugs::Packages module provides support functions to map binary
  39 packages to their corresponding source packages and vice versa. (This makes
  40 sense for software distributions, where developers may work on a single
  41 source package which produces several binary packages for use by users; it
  42 may not make sense in other contexts.)
  43
  44 =head1 METHODS
  45
  46 =over 8
  47
  48 =item getpkgsrc
  49
  50 Returns a reference to a hash of binary package names to their corresponding
  51 source package names.
  52
  53 =cut
  54
  55 our $_pkgsrc;
  56 our $_pkgcomponent;
  57 our $_srcpkg;
  58 sub getpkgsrc {
  59     return $_pkgsrc if $_pkgsrc;
  60     return {} unless defined $Debbugs::Packages::gPackageSource;
  61     my %pkgsrc;
  62     my %pkgcomponent;
  63     my %srcpkg;
  64
  65     open(MM,"$Debbugs::Packages::gPackageSource")
  66         or die("open $Debbugs::Packages::gPackageSource: $!");
  67     while(<MM>) {
  68         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
  69         my ($bin,$cmp,$src)=($1,$2,$3);
  70         $bin =~ y/A-Z/a-z/;
  71         $pkgsrc{$bin}= $src;
  72         push @{$srcpkg{$src}}, $bin;
  73         $pkgcomponent{$bin}= $cmp;
  74     }
  75     close(MM);
  76     $_pkgsrc = \%pkgsrc;
  77     $_pkgcomponent = \%pkgcomponent;
  78     $_srcpkg = \%srcpkg;
  79     return $_pkgsrc;
  80 }
  81
  82 =item getpkgcomponent
  83
  84 Returns a reference to a hash of binary package names to the component of
  85 the archive containing those binary packages (e.g. "main", "contrib",
  86 "non-free").
  87
  88 =cut
  89
  90 sub getpkgcomponent {
  91     return $_pkgcomponent if $_pkgcomponent;
  92     getpkgsrc();
  93     return $_pkgcomponent;
  94 }
  95
  96 =item getsrcpkgs
  97
  98 Returns a list of the binary packages produced by a given source package.
  99
 100 =cut
 101
 102 sub getsrcpkgs {
 103     my $src = shift;
 104     getpkgsrc() if not defined $_srcpkg;
 105     return () if not defined $src or not exists $_srcpkg->{$src};
 106     return @{$_srcpkg->{$src}};
 107 }
 108
 109 =item binarytosource
 110
 111 Returns a reference to the source package name and version pair
 112 corresponding to a given binary package name, version, and architecture. If
 113 undef is passed as the architecture, returns a list of references to all
 114 possible pairs of source package names and versions for all architectures,
 115 with any duplicates removed.
 116
 117 =cut
 118
 119 our %_binarytosource;
 120 sub binarytosource {
 121     my ($binname, $binver, $binarch) = @_;
 122
 123     # TODO: This gets hit a lot, especially from buggyversion() - probably
 124     # need an extra cache for speed here.
 125     return () unless defined $gBinarySourceMap;
 126
 127     if (tied %_binarytosource or
 128             tie %_binarytosource, 'MLDBM',
 129                 $gBinarySourceMap, O_RDONLY) {
 130         # avoid autovivification
 131         my $binary = $_binarytosource{$binname};
 132         return () unless defined $binary;
 133         my %binary = %{$binary};
 134         if (exists $binary{$binver}) {
 135             if (defined $binarch) {
 136                 my $src = $binary{$binver}{$binarch};
 137                 return () unless defined $src; # not on this arch
 138                 # Copy the data to avoid tiedness problems.
 139                 return dclone($src);
 140             } else {
 141                 # Get (srcname, srcver) pairs for all architectures and
 142                 # remove any duplicates. This involves some slightly tricky
 143                 # multidimensional hashing; sorry. Fortunately there'll
 144                 # usually only be one pair returned.
 145                 my %uniq;
 146                 for my $ar (keys %{$binary{$binver}}) {
 147                     my $src = $binary{$binver}{$ar};
 148                     next unless defined $src;
 149                     $uniq{$src->[0]}{$src->[1]} = 1;
 150                 }
 151                 my @uniq;
 152                 for my $sn (sort keys %uniq) {
 153                     push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 154                 }
 155                 return @uniq;
 156             }
 157         }
 158     }
 159
 160     # No $gBinarySourceMap, or it didn't have an entry for this name and
 161     # version.
 162     return ();
 163 }
 164
 165 =item sourcetobinary
 166
 167 Returns a list of references to triplets of binary package names, versions,
 168 and architectures corresponding to a given source package name and version.
 169 If the given source package name and version cannot be found in the database
 170 but the source package name is in the unversioned package-to-source map
 171 file, then a reference to a binary package name and version pair will be
 172 returned, without the architecture.
 173
 174 =cut
 175
 176 our %_sourcetobinary;
 177 sub sourcetobinary {
 178     my ($srcname, $srcver) = @_;
 179
 180     if (tied %_sourcetobinary or
 181             tie %_sourcetobinary, 'MLDBM',
 182                 $gSourceBinaryMap, O_RDONLY) {
 183         # avoid autovivification
 184         my $source = $_sourcetobinary{$srcname};
 185         return () unless defined $source;
 186         my %source = %{$source};
 187         if (exists $source{$srcver}) {
 188             my $bin = $source{$srcver};
 189             return () unless defined $bin;
 190             return @$bin;
 191         }
 192     }
 193
 194     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 195     # version. Try $gPackageSource (unversioned) instead.
 196     my @srcpkgs = getsrcpkgs($srcname);
 197     return map [$_, $srcver], @srcpkgs;
 198 }
 199
 200 =item getversions
 201
 202 Returns versions of the package in a distribution at a specific
 203 architecture
 204
 205 =cut
 206
 207 our %_versions;
 208 sub getversions {
 209     my ($pkg, $dist, $arch) = @_;
 210     return () unless defined $gVersionIndex;
 211     $dist = 'unstable' unless defined $dist;
 212
 213     unless (tied %_versions) {
 214         tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 215             or die "can't open versions index: $!";
 216     }
 217     my $version = $_versions{$pkg};
 218     return () unless defined $version;
 219     my %version = %{$version};
 220
 221     if (defined $arch and exists $version{$dist}{$arch}) {
 222         my $ver = $version{$dist}{$arch};
 223         return $ver if defined $ver;
 224         return ();
 225     } else {
 226         my %uniq;
 227         for my $ar (keys %{$version{$dist}}) {
 228             $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
 229         }
 230         if (%uniq) {
 231             return keys %uniq;
 232         } elsif (exists $version{$dist}{source}) {
 233             # Maybe this is actually a source package with no corresponding
 234             # binaries?
 235             return $version{$dist}{source};
 236         } else {
 237             return ();
 238         }
 239     }
 240 }
 241
 242
 243 =item makesourceversions
 244
 245      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 246
 247 Canonicalize versions into source versions, which have an explicitly
 248 named source package. This is used to cope with source packages whose
 249 names have changed during their history, and with cases where source
 250 version numbers differ from binary version numbers.
 251
 252 =cut
 253
 254 our %_sourceversioncache = ();
 255 sub makesourceversions {
 256     my $pkg = shift;
 257     my $arch = shift;
 258     my %sourceversions;
 259
 260     for my $version (@_) {
 261         if ($version =~ m[/]) {
 262             # Already a source version.
 263             $sourceversions{$version} = 1;
 264         } else {
 265             my $cachearch = (defined $arch) ? $arch : '';
 266             my $cachekey = "$pkg/$cachearch/$version";
 267             if (exists($_sourceversioncache{$cachekey})) {
 268                 for my $v (@{$_sourceversioncache{$cachekey}}) {
 269                     $sourceversions{$v} = 1;
 270                 }
 271                 next;
 272             }
 273
 274             my @srcinfo = binarytosource($pkg, $version, $arch);
 275             unless (@srcinfo) {
 276                 # We don't have explicit information about the
 277                 # binary-to-source mapping for this version (yet). Since
 278                 # this is a CGI script and our output is transient, we can
 279                 # get away with just looking in the unversioned map; if it's
 280                 # wrong (as it will be when binary and source package
 281                 # versions differ), too bad.
 282                 my $pkgsrc = getpkgsrc();
 283                 if (exists $pkgsrc->{$pkg}) {
 284                     @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 285                 } elsif (getsrcpkgs($pkg)) {
 286                     # If we're looking at a source package that doesn't have
 287                     # a binary of the same name, just try the same version.
 288                     @srcinfo = ([$pkg, $version]);
 289                 } else {
 290                     next;
 291                 }
 292             }
 293             $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 294             $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 295         }
 296     }
 297
 298     return sort keys %sourceversions;
 299 }
 300
 301
 302
 303 =back
 304
 305 =cut
 306
 307 1;