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.
 154     return ();
 155 }
 156
 157 =item sourcetobinary
 158
 159 Returns a list of references to triplets of binary package names, versions,
 160 and architectures corresponding to a given source package name and version.
 161 If the given source package name and version cannot be found in the database
 162 but the source package name is in the unversioned package-to-source map
 163 file, then a reference to a binary package name and version pair will be
 164 returned, without the architecture.
 165
 166 =cut
 167
 168 my %_sourcetobinary;
 169 sub sourcetobinary {
 170     my ($srcname, $srcver) = @_;
 171
 172     if (tied %_sourcetobinary or
 173             tie %_sourcetobinary, 'MLDBM',
 174                 $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
 175         # avoid autovivification
 176         if (exists $_sourcetobinary{$srcname} and
 177                 exists $_sourcetobinary{$srcname}{$srcver}) {
 178             my $bin = $_sourcetobinary{$srcname}{$srcver};
 179             return () unless defined $bin;
 180             # Copy the data to avoid tiedness problems.
 181             return @$bin;
 182         }
 183     }
 184
 185     # No $gSourceBinaryMap, or it didn't have an entry for this name and
 186     # version. Try $gPackageSource (unversioned) instead.
 187     my @srcpkgs = getsrcpkgs($srcname);
 188     return map [$_, $srcver], @srcpkgs;
 189 }
 190
 191 =back
 192
 193 =cut
 194
 195 1;