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