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 my $_pkgsrc;
  56 my $_pkgcomponent;
  57 my $_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 my %_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
 126     if (tied %_binarytosource or
 127             tie %_binarytosource, 'MLDBM',
 128                 $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
 129         # avoid autovivification
 130         my $binary = $_binarytosource{$binname};
 131         return () unless defined $binary;
 132         my %binary = %{$binary};
 133         if (exists $binary{$binver}) {
 134             if (defined $binarch) {
 135                 my $src = $binary{$binver}{$binarch};
 136                 return () unless defined $src; # not on this arch
 137                 # Copy the data to avoid tiedness problems.
 138                 return dclone($src);
 139             } else {
 140                 # Get (srcname, srcver) pairs for all architectures and
 141                 # remove any duplicates. This involves some slightly tricky
 142                 # multidimensional hashing; sorry. Fortunately there'll
 143                 # usually only be one pair returned.
 144                 my %uniq;
 145                 for my $ar (keys %{$binary{$binver}}) {
 146                     my $src = $binary{$binver}{$ar};
 147                     next unless defined $src;
 148                     $uniq{$src->[0]}{$src->[1]} = 1;
 149                 }
 150                 my @uniq;
 151                 for my $sn (sort keys %uniq) {
 152                     push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 153                 }
 154                 return @uniq;
 155             }
 156         }
 157     }
 158
 159     # No $gBinarySourceMap, or it didn't have an entry for this name and
 160     # version.
 161     return ();
 162 }
 163
 164 =item sourcetobinary
 165
 166 Returns a list of references to triplets of binary package names, versions,
 167 and architectures corresponding to a given source package name and version.
 168 If the given source package name and version cannot be found in the database
 169 but the source package name is in the unversioned package-to-source map
 170 file, then a reference to a binary package name and version pair will be
 171 returned, without the architecture.
 172
 173 =cut
 174
 175 my %_sourcetobinary;
 176 sub sourcetobinary {
 177     my ($srcname, $srcver) = @_;
 178
 179     if (tied %_sourcetobinary or
 180             tie %_sourcetobinary, 'MLDBM',
 181                 $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
 182         # avoid autovivification
 183         my $source = $_sourcetobinary{$srcname};
 184         return () unless defined $source;
 185         my %source = %{$source};
 186         if (exists $source{$srcver}) {
 187             my $bin = $source{$srcver};
 188             return () unless defined $bin;
 189             return @$bin;
 190         }
 191     }
 192
 193     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 194     # version. Try $gPackageSource (unversioned) instead.
 195     my @srcpkgs = getsrcpkgs($srcname);
 196     return map [$_, $srcver], @srcpkgs;
 197 }
 198
 199 =item getversions
 200
 201 Returns versions of the package in a distribution at a specific
 202 architecture
 203
 204 =cut
 205
 206 my %_versions;
 207 sub getversions {
 208     my ($pkg, $dist, $arch) = @_;
 209     return () unless defined $gVersionIndex;
 210     $dist = 'unstable' unless defined $dist;
 211
 212     unless (tied %_versions) {
 213         tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY
 214             or die "can't open versions index: $!";
 215     }
 216     my $version = $_versions{$pkg};
 217     return () unless defined $version;
 218     my %version = %{$version};
 219
 220     if (defined $arch and exists $version{$dist}{$arch}) {
 221         my $ver = $version{$pkg}{$dist}{$arch};
 222         return $ver if defined $ver;
 223         return ();
 224     } else {
 225         my %uniq;
 226         for my $ar (keys %{$version{$dist}}) {
 227             $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
 228         }
 229         if (%uniq) {
 230             return keys %uniq;
 231         } elsif (exists $version{$dist}{source}) {
 232             # Maybe this is actually a source package with no corresponding
 233             # binaries?
 234             return $version{$dist}{source};
 235         } else {
 236             return ();
 237         }
 238     }
 239 }
 240
 241
 242 =item makesourceversions
 243
 244      @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
 245
 246 Canonicalize versions into source versions, which have an explicitly
 247 named source package. This is used to cope with source packages whose
 248 names have changed during their history, and with cases where source
 249 version numbers differ from binary version numbers.
 250
 251 =cut
 252
 253 my %_sourceversioncache = ();
 254 sub makesourceversions {
 255     my $pkg = shift;
 256     my $arch = shift;
 257     my %sourceversions;
 258
 259     for my $version (@_) {
 260         if ($version =~ m[/]) {
 261             # Already a source version.
 262             $sourceversions{$version} = 1;
 263         } else {
 264             my $cachearch = (defined $arch) ? $arch : '';
 265             my $cachekey = "$pkg/$cachearch/$version";
 266             if (exists($_sourceversioncache{$cachekey})) {
 267                 for my $v (@{$_sourceversioncache{$cachekey}}) {
 268                     $sourceversions{$v} = 1;
 269                 }
 270                 next;
 271             }
 272
 273             my @srcinfo = binarytosource($pkg, $version, $arch);
 274             unless (@srcinfo) {
 275                 # We don't have explicit information about the
 276                 # binary-to-source mapping for this version (yet). Since
 277                 # this is a CGI script and our output is transient, we can
 278                 # get away with just looking in the unversioned map; if it's
 279                 # wrong (as it will be when binary and source package
 280                 # versions differ), too bad.
 281                 my $pkgsrc = getpkgsrc();
 282                 if (exists $pkgsrc->{$pkg}) {
 283                     @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 284                 } elsif (getsrcpkgs($pkg)) {
 285                     # If we're looking at a source package that doesn't have
 286                     # a binary of the same name, just try the same version.
 287                     @srcinfo = ([$pkg, $version]);
 288                 } else {
 289                     next;
 290                 }
 291             }
 292             $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 293             $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 294         }
 295     }
 296
 297     return sort keys %sourceversions;
 298 }
 299
 300
 301
 302 =back
 303
 304 =cut
 305
 306 1;