Debbugs/Packages.pm

   1 package Debbugs::Packages;
   2
   3 use strict;
   4
   5 # TODO: move config handling to a separate module
   6 my $config_path = '/etc/debbugs';
   7 require "$config_path/config";
   8
   9 use Exporter ();
  10 use vars qw($VERSION @ISA @EXPORT);
  11
  12 BEGIN {
  13     $VERSION = 1.00;
  14
  15     @ISA = qw(Exporter);
  16     @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs
  17                  binarytosource sourcetobinary);
  18 }
  19
  20 use Fcntl qw(O_RDONLY);
  21 use MLDBM qw(DB_File);
  22
  23 $MLDBM::RemoveTaint = 1;
  24
  25 =head1 NAME
  26
  27 Debbugs::Packages - debbugs binary/source package handling
  28
  29 =head1 DESCRIPTION
  30
  31 The Debbugs::Packages module provides support functions to map binary
  32 packages to their corresponding source packages and vice versa. (This makes
  33 sense for software distributions, where developers may work on a single
  34 source package which produces several binary packages for use by users; it
  35 may not make sense in other contexts.)
  36
  37 =head1 METHODS
  38
  39 =over 8
  40
  41 =item getpkgsrc
  42
  43 Returns a reference to a hash of binary package names to their corresponding
  44 source package names.
  45
  46 =cut
  47
  48 my $_pkgsrc;
  49 my $_pkgcomponent;
  50 sub getpkgsrc {
  51     return $_pkgsrc if $_pkgsrc;
  52     return {} unless defined $Debbugs::Packages::gPackageSource;
  53     my %pkgsrc;
  54     my %pkgcomponent;
  55
  56     open(MM,"$Debbugs::Packages::gPackageSource")
  57         or &quitcgi("open $Debbugs::Packages::gPackageSource: $!");
  58     while(<MM>) {
  59         next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
  60         my ($bin,$cmp,$src)=($1,$2,$3);
  61         $bin =~ y/A-Z/a-z/;
  62         $pkgsrc{$bin}= $src;
  63         $pkgcomponent{$bin}= $cmp;
  64     }
  65     close(MM);
  66     $_pkgsrc = \%pkgsrc;
  67     $_pkgcomponent = \%pkgcomponent;
  68     return $_pkgsrc;
  69 }
  70
  71 =item getpkgcomponent
  72
  73 Returns a reference to a hash of binary package names to the component of
  74 the archive containing those binary packages (e.g. "main", "contrib",
  75 "non-free").
  76
  77 =cut
  78
  79 sub getpkgcomponent {
  80     return $_pkgcomponent if $_pkgcomponent;
  81     getpkgsrc();
  82     return $_pkgcomponent;
  83 }
  84
  85 =item getsrcpkgs
  86
  87 Returns a list of the binary packages produced by a given source package.
  88
  89 =cut
  90
  91 sub getsrcpkgs {
  92     my $src = shift;
  93     return () if !$src;
  94     my %pkgsrc = %{getpkgsrc()};
  95     my @pkgs;
  96     foreach ( keys %pkgsrc ) {
  97         push @pkgs, $_ if $pkgsrc{$_} eq $src;
  98     }
  99     return @pkgs;
 100 }
 101
 102 =item binarytosource
 103
 104 Returns a reference to the source package name and version pair
 105 corresponding to a given binary package name, version, and architecture. If
 106 undef is passed as the architecture, returns a list of references to all
 107 possible pairs of source package names and versions for all architectures,
 108 with any duplicates removed.
 109
 110 =cut
 111
 112 my %_binarytosource;
 113 sub binarytosource {
 114     my ($binname, $binver, $binarch) = @_;
 115
 116     # TODO: This gets hit a lot, especially from buggyversion() - probably
 117     # need an extra cache for speed here.
 118
 119     if (tied %_binarytosource or
 120             tie %_binarytosource, 'MLDBM',
 121                 $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
 122         # avoid autovivification
 123         if (exists $_binarytosource{$binname} and
 124                 exists $_binarytosource{$binname}{$binver}) {
 125             if (defined $binarch) {
 126                 my $src = $_binarytosource{$binname}{$binver}{$binarch};
 127                 return () unless defined $src; # not on this arch
 128                 # Copy the data to avoid tiedness problems.
 129                 return [@$src];
 130             } else {
 131                 # Get (srcname, srcver) pairs for all architectures and
 132                 # remove any duplicates. This involves some slightly tricky
 133                 # multidimensional hashing; sorry. Fortunately there'll
 134                 # usually only be one pair returned.
 135                 my %uniq;
 136                 for my $ar (keys %{$_binarytosource{$binname}{$binver}}) {
 137                     my $src = $_binarytosource{$binname}{$binver}{$ar};
 138                     next unless defined $src;
 139                     $uniq{$src->[0]}{$src->[1]} = 1;
 140                 }
 141                 my @uniq;
 142                 for my $sn (sort keys %uniq) {
 143                     push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 144                 }
 145                 return @uniq;
 146             }
 147         }
 148     }
 149
 150     # No $gBinarySourceMap, or it didn't have an entry for this name and
 151     # version. Try $gPackageSource (unversioned) instead.
 152     my $pkgsrc = getpkgsrc();
 153     if (exists $pkgsrc->{$binname}) {
 154         return [$pkgsrc->{$binname}, $binver];
 155     } else {
 156         return ();
 157     }
 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 =back
 195
 196 =cut
 197
 198 1;